From 1b212221c30c4ee17429ee34d26275396ca0ee26 Mon Sep 17 00:00:00 2001 From: Thomas Dinsdale-Young Date: Mon, 9 Sep 2024 09:57:46 +0200 Subject: [PATCH 1/2] Type-safe BlobStore (WIP). --- .../src/Concordium/Afgjort/Finalize.hs | 3 + .../src/Concordium/GlobalState/AccountMap.hs | 12 +- .../src/Concordium/GlobalState/BlockState.hs | 30 +- .../GlobalState/ContractStateFFIHelpers.hs | 12 +- .../Concordium/GlobalState/ContractStateV1.hs | 84 ++-- .../GlobalState/Persistent/Account.hs | 193 ++++---- .../Persistent/Account/CooldownQueue.hs | 52 +-- .../Persistent/Account/EncryptedAmount.hs | 40 +- .../Persistent/Account/StructureV0.hs | 323 ++++++++------ .../Persistent/Account/StructureV1.hs | 337 +++++++------- .../GlobalState/Persistent/Accounts.hs | 170 +++++--- .../GlobalState/Persistent/BlobStore.hs | 411 +++++++++--------- .../BlockState/AccountReleaseSchedule.hs | 51 ++- .../BlockState/AccountReleaseScheduleV1.hs | 48 +- .../Persistent/BlockState/Updates.hs | 272 ++++++------ .../GlobalState/Persistent/Cache.hs | 35 +- .../GlobalState/Persistent/CachedRef.hs | 124 +++--- .../GlobalState/Persistent/LFMBTree.hs | 36 +- .../Concordium/GlobalState/Persistent/LMDB.hs | 2 +- .../GlobalState/Persistent/PoolRewards.hs | 54 ++- .../Concordium/GlobalState/Persistent/Trie.hs | 17 +- 21 files changed, 1238 insertions(+), 1068 deletions(-) diff --git a/concordium-consensus/src/Concordium/Afgjort/Finalize.hs b/concordium-consensus/src/Concordium/Afgjort/Finalize.hs index a96294b403..e5ef06895f 100644 --- a/concordium-consensus/src/Concordium/Afgjort/Finalize.hs +++ b/concordium-consensus/src/Concordium/Afgjort/Finalize.hs @@ -73,6 +73,7 @@ import Concordium.GlobalState.BlockPointer import Concordium.GlobalState.BlockState import Concordium.GlobalState.Finalization import Concordium.GlobalState.Parameters +import Concordium.GlobalState.Persistent.BlobStore (MBSStore) import Concordium.GlobalState.Transactions import Concordium.GlobalState.TreeState import Concordium.Kontrol @@ -1158,6 +1159,8 @@ newtype ActiveFinalizationM (pv :: ProtocolVersion) (r :: Type) (s :: Type) (m : SkovQueryMonad ) +type instance MBSStore (ActiveFinalizationM pv r s m) = MBSStore m + deriving instance (MonadProtocolVersion m) => MonadProtocolVersion (ActiveFinalizationM pv r s m) deriving instance GlobalStateTypes (ActiveFinalizationM pv r s m) diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap.hs index 32096b21c6..fc9b694176 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap.hs @@ -69,13 +69,13 @@ newtype AccountMap (pv :: ProtocolVersion) fix = AccountMap } -- | The account map to be used in the persistent block state. -type PersistentAccountMap pv = AccountMap pv BufferedFix +type PersistentAccountMap store pv = AccountMap pv (BufferedFix store) -- | See documentation of @migratePersistentBlockState@. migratePersistentAccountMap :: (BlobStorable m AccountIndex, BlobStorable (t m) AccountIndex, MonadTrans t) => - PersistentAccountMap oldpv -> - t m (PersistentAccountMap pv) + PersistentAccountMap (MBSStore m) oldpv -> + t m (PersistentAccountMap (MBSStore (t m)) pv) migratePersistentAccountMap (AccountMap am) = AccountMap <$> Trie.migrateTrieN True return am -- | The account map that is purely in memory and used in the basic block state. @@ -83,11 +83,11 @@ type PureAccountMap pv = AccountMap pv Fix -- Necessary state storage instances for the persistent map. The pure one is not -- stored so does not need the related instances. -instance (MonadBlobStore m) => Cacheable m (PersistentAccountMap pv) where +instance (MonadBlobStore m, store ~ MBSStore m) => Cacheable m (PersistentAccountMap store pv) where cache (AccountMap am) = AccountMap <$> cache am {-# INLINE cache #-} -instance (MonadBlobStore m) => BlobStorable m (PersistentAccountMap pv) where +instance (MonadBlobStore m, store ~ MBSStore m) => BlobStorable m (PersistentAccountMap store pv) where storeUpdate (AccountMap am) = second AccountMap <$> storeUpdate am {-# INLINE storeUpdate #-} @@ -95,7 +95,7 @@ instance (MonadBlobStore m) => BlobStorable m (PersistentAccountMap pv) where {-# INLINE load #-} -- | Convert a pure account map to the persistent one. -toPersistent :: (MonadBlobStore m) => PureAccountMap pv -> m (PersistentAccountMap pv) +toPersistent :: (MonadBlobStore m) => PureAccountMap pv -> m (PersistentAccountMap (MBSStore m) pv) toPersistent = fmap AccountMap . Trie.fromTrie . unAccountMap -- Aliases for reducing constraint repetition in methods below. diff --git a/concordium-consensus/src/Concordium/GlobalState/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/BlockState.hs index b3034a13ec..f4031574a3 100644 --- a/concordium-consensus/src/Concordium/GlobalState/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/BlockState.hs @@ -311,30 +311,30 @@ class (BlockStateTypes m, Monad m) => AccountOperations m where -- state. At the end of contract execution the mutable state is "frozen", which -- converts it to the persistent version, retaining as much sharing as possible -- with the previous version. -type family UpdatableContractState (v :: Wasm.WasmVersion) = ty | ty -> v where - UpdatableContractState GSWasm.V0 = Wasm.ContractState - UpdatableContractState GSWasm.V1 = StateV1.MutableState +type family UpdatableContractState store (v :: Wasm.WasmVersion) = ty | ty -> v where + UpdatableContractState store GSWasm.V0 = Wasm.ContractState + UpdatableContractState store GSWasm.V1 = StateV1.MutableState store -- | An external representation of the persistent (i.e., frozen) contract state. -- This is used to pass this state through FFI for queries and should not be -- used during contract execution in the scheduler since it's considered an -- implementation detail and needs to be used together with the correct loader -- callback. Higher-level abstractions should be used in the scheduler. -type family ExternalContractState (v :: Wasm.WasmVersion) = ty | ty -> v where - ExternalContractState GSWasm.V0 = Wasm.ContractState - ExternalContractState GSWasm.V1 = StateV1.PersistentState +type family ExternalContractState store (v :: Wasm.WasmVersion) = ty | ty -> v where + ExternalContractState store GSWasm.V0 = Wasm.ContractState + ExternalContractState store GSWasm.V1 = StateV1.PersistentState store class (BlockStateTypes m, Monad m) => ContractStateOperations m where -- | Convert a persistent state to a mutable one that can be updated by the -- scheduler. This function must generate independent mutable states for -- each invocation, where independent means that updates to different -- versions are __not__ reflected in others. - thawContractState :: ContractState m v -> m (UpdatableContractState v) + thawContractState :: ContractState m v -> m (UpdatableContractState (MBSStore m) v) -- | Convert a persistent state to its external representation that can be -- passed through FFI. The state should be used together with the -- callbacks returned by 'getV1StateContext'. - externalContractState :: ContractState m v -> m (ExternalContractState v) + externalContractState :: ContractState m v -> m (ExternalContractState (MBSStore m) v) -- | Get the callback to allow loading the contract state. Contracts are -- executed on the other end of FFI, and state is managed by Haskell, this @@ -342,7 +342,7 @@ class (BlockStateTypes m, Monad m) => ContractStateOperations m where -- -- V0 state is a simple byte-array which is copied over the FFI boundary, so -- it does not require an analogous construct. - getV1StateContext :: m LoadCallback + getV1StateContext :: m (LoadCallback (MBSStore m)) -- | Size of the persistent V0 state. The way charging is done for V0 -- contracts requires us to get this information when loading the state __at @@ -698,7 +698,7 @@ mintTotal MintAmounts{..} = mintBakingReward + mintFinalizationReward + mintDeve -- to simplify function API. Thus values are immediately deconstructed. -- It is parameterized by the concrete instrumented module @im@ and the -- WasmVersion @v@. -data NewInstanceData im v = NewInstanceData +data NewInstanceData store im v = NewInstanceData { -- | Name of the init method used to initialize the contract. nidInitName :: Wasm.InitName, -- | Receive functions suitable for this instance. @@ -706,7 +706,7 @@ data NewInstanceData im v = NewInstanceData -- | Module interface that contains the code of the contract. nidInterface :: GSWasm.ModuleInterfaceA im, -- | Initial state of the instance. - nidInitialState :: UpdatableContractState v, + nidInitialState :: UpdatableContractState store v, -- | Initial balance. nidInitialAmount :: Amount, -- | Owner/creator of the instance. @@ -774,7 +774,7 @@ class (BlockStateQuery m) => BlockStateOperations m where bsoCreateAccount :: UpdatableBlockState m -> GlobalContext -> AccountAddress -> AccountCredential -> m (Maybe (Account m), UpdatableBlockState m) -- | Add a new smart contract instance to the state. - bsoPutNewInstance :: forall v. (Wasm.IsWasmVersion v) => UpdatableBlockState m -> NewInstanceData (InstrumentedModuleRef m v) v -> m (ContractAddress, UpdatableBlockState m) + bsoPutNewInstance :: forall v. (Wasm.IsWasmVersion v) => UpdatableBlockState m -> NewInstanceData (MBSStore m) (InstrumentedModuleRef m v) v -> m (ContractAddress, UpdatableBlockState m) -- | Add the module to the global state. If a module with the given address -- already exists return @False@. @@ -838,7 +838,7 @@ class (BlockStateQuery m) => BlockStateOperations m where UpdatableBlockState m -> ContractAddress -> AmountDelta -> - Maybe (UpdatableContractState v) -> + Maybe (UpdatableContractState (MBSStore m) v) -> Maybe (GSWasm.ModuleInterfaceA (InstrumentedModuleRef m v), Set.Set Wasm.ReceiveName) -> m (UpdatableBlockState m) @@ -1584,7 +1584,7 @@ class (BlockStateOperations m, FixedSizeSerialization (BlockStateRef m)) => Bloc -- | Retrieve the callback that is needed to read state that is not in -- memory. This is needed for using V1 contract state. - blockStateLoadCallback :: m LoadCallback + blockStateLoadCallback :: m (LoadCallback (MBSStore m)) -- | Shut down any caches used by the block state. This is used to free -- up the memory in the case where the block state is no longer being @@ -1725,6 +1725,7 @@ instance (Monad (t m), MonadTrans t, AccountOperations m) => AccountOperations ( {-# INLINE getAccountHash #-} {-# INLINE getAccountCooldowns #-} +type instance MBSStore (MGSTrans t m) = MBSStore m instance (Monad (t m), MonadTrans t, ContractStateOperations m) => ContractStateOperations (MGSTrans t m) where thawContractState = lift . thawContractState {-# INLINE thawContractState #-} @@ -1902,6 +1903,7 @@ instance (Monad (t m), MonadTrans t, BlockStateStorage m) => BlockStateStorage ( {-# INLINE cacheBlockStateAndGetTransactionTable #-} {-# INLINE tryPopulateAccountMap #-} +type instance MBSStore (MaybeT m) = MBSStore m deriving via (MGSTrans MaybeT m) instance (BlockStateQuery m) => BlockStateQuery (MaybeT m) deriving via (MGSTrans MaybeT m) instance (AccountOperations m) => AccountOperations (MaybeT m) deriving via (MGSTrans MaybeT m) instance (ContractStateOperations m) => ContractStateOperations (MaybeT m) diff --git a/concordium-consensus/src/Concordium/GlobalState/ContractStateFFIHelpers.hs b/concordium-consensus/src/Concordium/GlobalState/ContractStateFFIHelpers.hs index 0d46372c09..260857e8d8 100644 --- a/concordium-consensus/src/Concordium/GlobalState/ContractStateFFIHelpers.hs +++ b/concordium-consensus/src/Concordium/GlobalState/ContractStateFFIHelpers.hs @@ -17,7 +17,7 @@ data Vec -- vector that should be passed to the Rust runtime. type LoadCallbackType = Word64 -> IO (Ptr Vec) -type LoadCallback = FunPtr LoadCallbackType +type LoadCallback store = FunPtr LoadCallbackType -- | Callback for writing to the blob store from the provided buffer. The -- arguments are the buffer where the data is and the amount of data to write. @@ -25,12 +25,12 @@ type LoadCallback = FunPtr LoadCallbackType -- location where data was written. type StoreCallbackType = Ptr Word8 -> CSize -> IO Word64 -type StoreCallback = FunPtr StoreCallbackType +type StoreCallback store = FunPtr StoreCallbackType -- | Wrappers for making callbacks from Haskell functions or closures. -foreign import ccall "wrapper" createLoadCallback :: LoadCallbackType -> IO LoadCallback +foreign import ccall "wrapper" createLoadCallback :: LoadCallbackType -> IO (LoadCallback store) -foreign import ccall "wrapper" createStoreCallback :: StoreCallbackType -> IO StoreCallback +foreign import ccall "wrapper" createStoreCallback :: StoreCallbackType -> IO (StoreCallback store) -- | Allocate and return a Rust vector that contains the given data. foreign import ccall "copy_to_vec_ffi" copyToRustVec :: Ptr Word8 -> CSize -> IO (Ptr Vec) @@ -39,9 +39,9 @@ foreign import ccall "copy_to_vec_ffi" copyToRustVec :: Ptr Word8 -> CSize -> IO -- implementation which never stores any data in the backing store. NOINLINE -- here ensures that only a single instance of callbacks is allocated. {-# NOINLINE errorLoadCallback #-} -errorLoadCallback :: LoadCallback +errorLoadCallback :: LoadCallback store errorLoadCallback = unsafePerformIO $ createLoadCallback (\_location -> error "Error load callback invoked, and it should not have been.") -- | Deallocate the callbacks. This should generally be called to not leak memory. -freeErrorCallback :: LoadCallback -> IO () +freeErrorCallback :: LoadCallback store -> IO () freeErrorCallback = freeHaskellFunPtr diff --git a/concordium-consensus/src/Concordium/GlobalState/ContractStateV1.hs b/concordium-consensus/src/Concordium/GlobalState/ContractStateV1.hs index b1ba0833fc..b47b9fbf49 100644 --- a/concordium-consensus/src/Concordium/GlobalState/ContractStateV1.hs +++ b/concordium-consensus/src/Concordium/GlobalState/ContractStateV1.hs @@ -46,51 +46,57 @@ import qualified Data.FixedByteString as FBS import Concordium.GlobalState.ContractStateFFIHelpers (LoadCallback, StoreCallback, errorLoadCallback) import Concordium.GlobalState.Persistent.BlobStore +-- | Opaque mutable state. +data ForeignMutableState store + -- | Opaque pointer to the mutable state. This state exists only for the duration -- of a transaction and is then deallocated by running a finalizer. -newtype MutableStateInner = MutableStateInner (ForeignPtr MutableStateInner) +newtype MutableStateInner store = MutableStateInner (ForeignPtr (ForeignMutableState store)) -- | Mutable state together with the context that determines how to load any data -- that is not in-memory. -data MutableState = MutableState - { msInner :: !MutableStateInner, - msContext :: !LoadCallback +data MutableState store = MutableState + { msInner :: !(MutableStateInner store), + msContext :: !(LoadCallback store) } -- | Attach a finalizer to the given allocated opaque mutable state reference. -- This function can be used at most once on any given pointer, otherwise data -- that is pointed to will be freed twice, leading to a memory access error. -newMutableState :: LoadCallback -> Ptr MutableStateInner -> IO MutableState +newMutableState :: LoadCallback store -> Ptr (ForeignMutableState store) -> IO (MutableState store) newMutableState msContext ptr = do msInner <- MutableStateInner <$> newForeignPtr freeMutableState ptr return MutableState{..} -- | Get temporary access to the mutable state pointer. The pointer should not be -- leaked from the computation. -withMutableState :: MutableState -> (Ptr MutableStateInner -> IO a) -> IO a +withMutableState :: MutableState store -> (Ptr (ForeignMutableState store) -> IO a) -> IO a withMutableState MutableState{msInner = MutableStateInner fp} = withForeignPtr fp +-- | Opaque persistent state. +data ForeignPersistentState store + -- | An opaque pointer to a contract instance's state. "Persistent" here is in -- the sense of "persistent data structures", meaning that the state is not -- updated in place, but that modifications create a copy of the relevant part -- of the structure. This state is thus designed so that as little data as -- possible needs to be modified by updates. An additional feature of this state -- is that it can be loaded into memory on-demand. -newtype PersistentState = PersistentState (ForeignPtr PersistentState) +newtype PersistentState store = PersistentState (ForeignPtr (ForeignPersistentState store)) -- | An in-memory variant of the 'PeristentState'. No operations ever write any -- part of the state to disk, and thus the entirety of this state is always -- in-memory. -newtype InMemoryPersistentState = InMemoryPersistentState PersistentState +newtype InMemoryPersistentState store = InMemoryPersistentState (PersistentState store) -- | Migrate the provided persistent state from the existing backing store (which -- can be accessed using the provided 'LoadCallback'), to the new backing store -- (that is written to using the provided 'StoreCallback'). The input persistent -- state remains valid. The new persistent state is not cached, it is entirely -- stored on disk. -foreign import ccall "migrate_persistent_tree_v1" migratePersistentTree :: LoadCallback -> StoreCallback -> Ptr PersistentState -> IO (Ptr PersistentState) +foreign import ccall "migrate_persistent_tree_v1" migratePersistentTree :: LoadCallback store -> StoreCallback store -> Ptr (ForeignPersistentState store) -> IO (Ptr (ForeignPersistentState store)) -migratePersistentState :: LoadCallback -> StoreCallback -> PersistentState -> IO PersistentState +migratePersistentState :: LoadCallback store -> StoreCallback store -> PersistentState store -> IO (PersistentState store) migratePersistentState lcbk scbk ps = do newPSPtr <- withPersistentState ps $ migratePersistentTree lcbk scbk newPS <- newForeignPtr freePersistentState newPSPtr @@ -98,49 +104,49 @@ migratePersistentState lcbk scbk ps = do -- | Gain temporary access to a pointer to the persistent state. The pointer -- should not be leaked from the computation. -withPersistentState :: PersistentState -> (Ptr PersistentState -> IO a) -> IO a +withPersistentState :: PersistentState store -> (Ptr (ForeignPersistentState store) -> IO a) -> IO a withPersistentState (PersistentState fp) = withForeignPtr fp -- | Convert an in-memory persistent state to a normal persistent state. Note -- that this does not store anything on disk. That has to be done separately by -- using the 'BlobStorable' implementation for PersistentState. -makePersistent :: InMemoryPersistentState -> PersistentState +makePersistent :: InMemoryPersistentState store -> PersistentState store makePersistent (InMemoryPersistentState st) = st -- | Load persistent state from the given disk reference. The provided closure is -- called to read data from persistent storage. -foreign import ccall "load_persistent_tree_v1" loadPersistentTree :: LoadCallback -> BlobRef PersistentState -> IO (Ptr PersistentState) +foreign import ccall "load_persistent_tree_v1" loadPersistentTree :: LoadCallback store -> BlobRef store (PersistentState store) -> IO (Ptr (ForeignPersistentState store)) -foreign import ccall unsafe "&free_persistent_state_v1" freePersistentState :: FunPtr (Ptr PersistentState -> IO ()) -foreign import ccall unsafe "&free_mutable_state_v1" freeMutableState :: FunPtr (Ptr MutableStateInner -> IO ()) +foreign import ccall unsafe "&free_persistent_state_v1" freePersistentState :: FunPtr (Ptr (ForeignPersistentState store) -> IO ()) +foreign import ccall unsafe "&free_mutable_state_v1" freeMutableState :: FunPtr (Ptr (ForeignMutableState store) -> IO ()) -- | Write out the tree using the provided callback, and return a BlobRef to the root. -foreign import ccall "store_persistent_tree_v1" storePersistentTree :: StoreCallback -> Ptr PersistentState -> IO (BlobRef PersistentState) +foreign import ccall "store_persistent_tree_v1" storePersistentTree :: StoreCallback store -> Ptr (ForeignPersistentState store) -> IO (BlobRef store (PersistentState store)) -- | Freeze the mutable state and compute the root hash. This leaves the mutable -- state empty (and thus mutable state should not be used after a call to this -- function), and writes the hash to the provided pointer, which should be able -- to hold 32 bytes. -foreign import ccall "freeze_mutable_state_v1" freezePersistentTree :: LoadCallback -> Ptr MutableStateInner -> Ptr Word8 -> IO (Ptr PersistentState) +foreign import ccall "freeze_mutable_state_v1" freezePersistentTree :: LoadCallback store -> Ptr (ForeignMutableState store) -> Ptr Word8 -> IO (Ptr (ForeignPersistentState store)) -- | Make a fresh mutable state from the persistent one. -foreign import ccall "thaw_persistent_state_v1" thawPersistentTree :: Ptr PersistentState -> IO (Ptr MutableStateInner) +foreign import ccall "thaw_persistent_state_v1" thawPersistentTree :: Ptr (ForeignPersistentState store) -> IO (Ptr (ForeignMutableState store)) -- | Get the amount of additional space that will be needed to store the new -- entries. -foreign import ccall "get_new_state_size_v1" getNewStateSizeFFI :: LoadCallback -> Ptr MutableStateInner -> IO Word64 +foreign import ccall "get_new_state_size_v1" getNewStateSizeFFI :: LoadCallback store -> Ptr (ForeignMutableState store) -> IO Word64 -- | Compute and retrieve the hash of the persistent state. The function is given -- a buffer to write the hash into. -foreign import ccall "hash_persistent_state_v1" hashPersistentState :: LoadCallback -> Ptr PersistentState -> Ptr Word8 -> IO () +foreign import ccall "hash_persistent_state_v1" hashPersistentState :: LoadCallback store -> Ptr (ForeignPersistentState store) -> Ptr Word8 -> IO () -- | Serialize the persistent state into a byte buffer. The return value is a -- pointer to the beginning of the buffer, and the last argument is where the -- length of the buffer is written. -foreign import ccall "serialize_persistent_state_v1" serializePersistentState :: LoadCallback -> Ptr PersistentState -> Ptr CSize -> IO (Ptr Word8) +foreign import ccall "serialize_persistent_state_v1" serializePersistentState :: LoadCallback store -> Ptr (ForeignPersistentState store) -> Ptr CSize -> IO (Ptr Word8) -- | Deserialize state from a byte buffer. -foreign import ccall "deserialize_persistent_state_v1" deserializePersistentState :: Ptr Word8 -> CSize -> IO (Ptr PersistentState) +foreign import ccall "deserialize_persistent_state_v1" deserializePersistentState :: Ptr Word8 -> CSize -> IO (Ptr (ForeignPersistentState store)) {-# NOINLINE getNewStateSize #-} @@ -148,12 +154,12 @@ foreign import ccall "deserialize_persistent_state_v1" deserializePersistentStat -- mutable state. This function is only called at the end of a transaction and -- may mutate the mutable state so that further operations, in particular -- @freeze@ are more efficient. -getNewStateSize :: MutableState -> Word64 +getNewStateSize :: MutableState store -> Word64 getNewStateSize ms = unsafePerformIO (withMutableState ms (getNewStateSizeFFI (msContext ms))) -- | Freeze the mutable state into a persistent state, computing its hash on the -- way. -freeze :: LoadCallback -> MutableState -> IO (SHA256.Hash, PersistentState) +freeze :: LoadCallback store -> MutableState store -> IO (SHA256.Hash, PersistentState store) freeze callbacks ms = do (psPtr, hashBytes) <- withMutableState ms $ \msPtr -> FBS.createWith (freezePersistentTree callbacks msPtr) ps <- newForeignPtr freePersistentState psPtr @@ -161,7 +167,7 @@ freeze callbacks ms = do -- | Convert the persistent state to a mutable one. This creates independent -- instances of mutable state for each call. -thaw :: LoadCallback -> PersistentState -> IO MutableState +thaw :: LoadCallback store -> PersistentState store -> IO (MutableState store) thaw msContext ms = do msPtr <- withPersistentState ms thawPersistentTree msInner <- MutableStateInner <$> newForeignPtr freeMutableState msPtr @@ -172,7 +178,7 @@ thaw msContext ms = do -- | A specialization of 'freeze', assuming that the mutable state only refers to -- in-memory parts persistent state, i.e., the 'MutableState' was thawed from an -- @InMemoryPersistentState@ and then modified by contract execution. -freezeInMemoryPersistent :: MutableState -> (SHA256.Hash, InMemoryPersistentState) +freezeInMemoryPersistent :: MutableState store -> (SHA256.Hash, InMemoryPersistentState store) freezeInMemoryPersistent ms = let (hsh, s) = unsafePerformIO $ freeze errorLoadCallback ms in (hsh, InMemoryPersistentState s) @@ -180,12 +186,12 @@ freezeInMemoryPersistent ms = {-# NOINLINE thawInMemoryPersistent #-} -- | A specialization of 'thaw' above, assuming that the persistent state has all data in-memory. -thawInMemoryPersistent :: InMemoryPersistentState -> MutableState +thawInMemoryPersistent :: InMemoryPersistentState store -> MutableState store thawInMemoryPersistent (InMemoryPersistentState ts) = unsafePerformIO $ thaw errorLoadCallback ts -instance (MonadBlobStore m) => BlobStorable m PersistentState where +instance (MonadBlobStore m) => BlobStorable m (PersistentState store) where load = do - br :: BlobRef PersistentState <- get + br :: BlobRef store (PersistentState store) <- get pure $! do loadCallback <- fst <$> getCallbacks liftIO $ @@ -201,21 +207,21 @@ instance (MonadBlobStore m) => BlobStorable m PersistentState where -- as we do not want to load smart contract state -- into memory prematurely. The smart contract state is loaded -- on demand and flushed to disk upon finalization. -instance (MonadBlobStore m) => Cacheable m PersistentState +instance (MonadBlobStore m) => Cacheable m (PersistentState store) -instance (MonadBlobStore m) => MHashableTo m SHA256.Hash PersistentState where +instance (MonadBlobStore m) => MHashableTo m SHA256.Hash (PersistentState store) where getHashM ps = do (cbk, _) <- getCallbacks ((), hsh) <- liftIO (withPersistentState ps $ FBS.createWith . hashPersistentState cbk) return (SHA256.Hash hsh) -instance HashableTo SHA256.Hash InMemoryPersistentState where +instance HashableTo SHA256.Hash (InMemoryPersistentState store) where {-# NOINLINE getHash #-} getHash (InMemoryPersistentState ps) = unsafePerformIO $ do ((), hsh) <- liftIO (withPersistentState ps $ FBS.createWith . hashPersistentState errorLoadCallback) return (SHA256.Hash hsh) -instance Serialize InMemoryPersistentState where +instance Serialize (InMemoryPersistentState store) where {-# NOINLINE get #-} get = do bs <- getByteStringLen @@ -233,17 +239,17 @@ instance Serialize InMemoryPersistentState where putByteStringLen <$> BSU.unsafePackCStringFinalizer (castPtr bytePtr) (fromIntegral len) (rs_free_array_len bytePtr (fromIntegral len)) {-# WARNING generatePersistentTreeFFI "Only for testing. DO NOT USE IN PRODUCTION." #-} -foreign import ccall "generate_persistent_state_from_seed" generatePersistentTreeFFI :: Word64 -> Word64 -> IO (Ptr PersistentState) +foreign import ccall "generate_persistent_state_from_seed" generatePersistentTreeFFI :: Word64 -> Word64 -> IO (Ptr (ForeignPersistentState store)) -- Functions that exist only for testing. {-# WARNING persistentStateV1Lookup "Not efficient. DO NOT USE IN PRODUCTION." #-} foreign import ccall "persistent_state_v1_lookup" persistentStateV1Lookup :: - LoadCallback -> + LoadCallback store -> Ptr Word8 -> -- | Pointer to the beginning of the key and its length. CSize -> - Ptr PersistentState -> + Ptr (ForeignPersistentState store) -> -- | Length of the output data, if the output pointer is not null. Ptr CSize -> IO (Ptr Word8) @@ -253,7 +259,7 @@ foreign import ccall "persistent_state_v1_lookup" -- | Lookup a value in the persistent contract state. This function is subject -- to stack overflow for maliciously constructed states, so must not be used in -- production. -lookupKey :: (MonadBlobStore m) => PersistentState -> BS.ByteString -> m (Maybe BS.ByteString) +lookupKey :: (MonadBlobStore m) => PersistentState store -> BS.ByteString -> m (Maybe BS.ByteString) lookupKey persistentState key = do loadCallback <- fst <$> getCallbacks liftIO $ withPersistentState persistentState $ \statePtr -> @@ -287,7 +293,7 @@ generatePersistentTree :: Word64 -> -- | Number of values. Word64 -> - InMemoryPersistentState + InMemoryPersistentState store generatePersistentTree seed len = unsafePerformIO $ do res <- generatePersistentTreeFFI seed len if res == nullPtr @@ -298,7 +304,7 @@ generatePersistentTree seed len = unsafePerformIO $ do -- update to construct the new genesis block. This method must be compatible -- with the @get@ method of the serialization instance of -- 'InMemoryPersistentState'. -toByteString :: (MonadBlobStore m) => PersistentState -> m BS.ByteString +toByteString :: (MonadBlobStore m) => PersistentState store -> m BS.ByteString toByteString ps = do loadCallback <- fst <$> getCallbacks liftIO $ withPersistentState ps $ \psPtr -> alloca $ \sizePtr -> do diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Account.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Account.hs index 464c886055..fe3886da7d 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Account.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Account.hs @@ -5,7 +5,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} --- | This module provides an interface for operating on peristent accounts. +-- | This module provides an interface for operating on persistent accounts. module Concordium.GlobalState.Persistent.Account where import Control.Arrow @@ -40,25 +40,25 @@ import Concordium.Logger -- * Account types -- | A persistent account at a particular 'AccountVersion'. -data PersistentAccount (av :: AccountVersion) where - PAV0 :: !(V0.PersistentAccount 'AccountV0) -> PersistentAccount 'AccountV0 - PAV1 :: !(V0.PersistentAccount 'AccountV1) -> PersistentAccount 'AccountV1 - PAV2 :: !(V1.PersistentAccount 'AccountV2) -> PersistentAccount 'AccountV2 - PAV3 :: !(V1.PersistentAccount 'AccountV3) -> PersistentAccount 'AccountV3 +data PersistentAccount store (av :: AccountVersion) where + PAV0 :: !(V0.PersistentAccount store 'AccountV0) -> PersistentAccount store 'AccountV0 + PAV1 :: !(V0.PersistentAccount store 'AccountV1) -> PersistentAccount store 'AccountV1 + PAV2 :: !(V1.PersistentAccount store 'AccountV2) -> PersistentAccount store 'AccountV2 + PAV3 :: !(V1.PersistentAccount store 'AccountV3) -> PersistentAccount store 'AccountV3 -instance (MonadBlobStore m) => MHashableTo m (AccountHash av) (PersistentAccount av) where +instance (MonadBlobStore m, store ~ MBSStore m) => MHashableTo m (AccountHash av) (PersistentAccount store av) where getHashM (PAV0 acc) = getHashM acc getHashM (PAV1 acc) = getHashM acc getHashM (PAV2 acc) = getHashM acc getHashM (PAV3 acc) = getHashM acc -instance (MonadBlobStore m) => MHashableTo m Hash.Hash (PersistentAccount av) where +instance (MonadBlobStore m, store ~ MBSStore m) => MHashableTo m Hash.Hash (PersistentAccount store av) where getHashM (PAV0 acc) = getHashM acc getHashM (PAV1 acc) = getHashM acc getHashM (PAV2 acc) = getHashM acc getHashM (PAV3 acc) = getHashM acc -instance (IsAccountVersion av, MonadBlobStore m) => BlobStorable m (PersistentAccount av) where +instance (IsAccountVersion av, MonadBlobStore m, store ~ MBSStore m) => BlobStorable m (PersistentAccount store av) where storeUpdate (PAV0 acct) = second PAV0 <$!> storeUpdate acct storeUpdate (PAV1 acct) = second PAV1 <$!> storeUpdate acct storeUpdate (PAV2 acct) = second PAV2 <$!> storeUpdate acct @@ -70,22 +70,23 @@ instance (IsAccountVersion av, MonadBlobStore m) => BlobStorable m (PersistentAc SAccountV3 -> fmap PAV3 <$> load -- | Type of references to persistent accounts. -type AccountRef (av :: AccountVersion) = HashedCachedRef (AccountCache av) (PersistentAccount av) +type AccountRef store (av :: AccountVersion) = + HashedCachedRef store (AccountCache store av) (PersistentAccount store av) -- | A reference to persistent baker info. -data PersistentBakerInfoRef (av :: AccountVersion) where - PBIRV0 :: !(V0.PersistentBakerInfoEx 'AccountV0) -> PersistentBakerInfoRef 'AccountV0 - PBIRV1 :: !(V0.PersistentBakerInfoEx 'AccountV1) -> PersistentBakerInfoRef 'AccountV1 - PBIRV2 :: !(V1.PersistentBakerInfoEx 'AccountV2) -> PersistentBakerInfoRef 'AccountV2 - PBIRV3 :: !(V1.PersistentBakerInfoEx 'AccountV3) -> PersistentBakerInfoRef 'AccountV3 +data PersistentBakerInfoRef store (av :: AccountVersion) where + PBIRV0 :: !(V0.PersistentBakerInfoEx store 'AccountV0) -> PersistentBakerInfoRef store 'AccountV0 + PBIRV1 :: !(V0.PersistentBakerInfoEx store 'AccountV1) -> PersistentBakerInfoRef store 'AccountV1 + PBIRV2 :: !(V1.PersistentBakerInfoEx store 'AccountV2) -> PersistentBakerInfoRef store 'AccountV2 + PBIRV3 :: !(V1.PersistentBakerInfoEx store 'AccountV3) -> PersistentBakerInfoRef store 'AccountV3 -instance Show (PersistentBakerInfoRef av) where +instance Show (PersistentBakerInfoRef store av) where show (PBIRV0 pibr) = show pibr show (PBIRV1 pibr) = show pibr show (PBIRV2 pibr) = show pibr show (PBIRV3 pibr) = show pibr -instance (IsAccountVersion av, MonadBlobStore m) => BlobStorable m (PersistentBakerInfoRef av) where +instance (IsAccountVersion av, MonadBlobStore m, store ~ MBSStore m) => BlobStorable m (PersistentBakerInfoRef store av) where storeUpdate (PBIRV0 bir) = second PBIRV0 <$!> storeUpdate bir storeUpdate (PBIRV1 bir) = second PBIRV1 <$!> storeUpdate bir storeUpdate (PBIRV2 bir) = second PBIRV2 <$!> storeUpdate bir @@ -99,23 +100,23 @@ instance (IsAccountVersion av, MonadBlobStore m) => BlobStorable m (PersistentBa -- * Account cache -- | Type alias for the cache to use for accounts. -type AccountCache (av :: AccountVersion) = FIFOCache (PersistentAccount av) +type AccountCache store (av :: AccountVersion) = FIFOCache store (PersistentAccount store av) -- | Construct a new 'AccountCache' with the given size. -newAccountCache :: Int -> IO (AccountCache av) +newAccountCache :: Int -> IO (AccountCache store av) newAccountCache = newCache -- * Queries -- | Get the canonical address of the account. -accountCanonicalAddress :: (MonadBlobStore m) => PersistentAccount av -> m AccountAddress +accountCanonicalAddress :: (MonadBlobStore m) => PersistentAccount (MBSStore m) av -> m AccountAddress accountCanonicalAddress (PAV0 acc) = V0.getCanonicalAddress acc accountCanonicalAddress (PAV1 acc) = V0.getCanonicalAddress acc accountCanonicalAddress (PAV2 acc) = V1.getCanonicalAddress acc accountCanonicalAddress (PAV3 acc) = V1.getCanonicalAddress acc -- | Get the current public account balance. -accountAmount :: (MonadBlobStore m) => PersistentAccount av -> m Amount +accountAmount :: (MonadBlobStore m) => PersistentAccount (MBSStore m) av -> m Amount accountAmount (PAV0 acc) = V0.getAmount acc accountAmount (PAV1 acc) = V0.getAmount acc accountAmount (PAV2 acc) = V1.getAmount acc @@ -123,21 +124,21 @@ accountAmount (PAV3 acc) = V1.getAmount acc -- | Gets the amount of a baker's stake, or 'Nothing' if the account is not a baker. -- This consists only of the active stake, and does not include any inactive stake. -accountBakerStakeAmount :: (MonadBlobStore m) => PersistentAccount av -> m (Maybe Amount) +accountBakerStakeAmount :: (MonadBlobStore m) => PersistentAccount (MBSStore m) av -> m (Maybe Amount) accountBakerStakeAmount (PAV0 acc) = V0.getBakerStakeAmount acc accountBakerStakeAmount (PAV1 acc) = V0.getBakerStakeAmount acc accountBakerStakeAmount (PAV2 acc) = V1.getBakerStakeAmount acc accountBakerStakeAmount (PAV3 acc) = V1.getBakerStakeAmount acc -- | Get the amount that is actively staked on an account as a baker or delegator. -accountActiveStakedAmount :: (MonadBlobStore m) => PersistentAccount av -> m Amount +accountActiveStakedAmount :: (MonadBlobStore m) => PersistentAccount (MBSStore m) av -> m Amount accountActiveStakedAmount (PAV0 acc) = V0.getStakedAmount acc accountActiveStakedAmount (PAV1 acc) = V0.getStakedAmount acc accountActiveStakedAmount (PAV2 acc) = V1.getActiveStakedAmount acc accountActiveStakedAmount (PAV3 acc) = V1.getActiveStakedAmount acc -- | Get the amount that is staked on the account (both active and inactive). -accountTotalStakedAmount :: (MonadBlobStore m) => PersistentAccount av -> m Amount +accountTotalStakedAmount :: (MonadBlobStore m) => PersistentAccount (MBSStore m) av -> m Amount accountTotalStakedAmount (PAV0 acc) = V0.getStakedAmount acc accountTotalStakedAmount (PAV1 acc) = V0.getStakedAmount acc accountTotalStakedAmount (PAV2 acc) = @@ -146,7 +147,7 @@ accountTotalStakedAmount (PAV2 acc) = accountTotalStakedAmount (PAV3 acc) = V1.getTotalStakedAmount acc -- | Get the amount that is locked in scheduled releases on the account. -accountLockedAmount :: (MonadBlobStore m) => PersistentAccount av -> m Amount +accountLockedAmount :: (MonadBlobStore m) => PersistentAccount (MBSStore m) av -> m Amount accountLockedAmount (PAV0 acc) = V0.getLockedAmount acc accountLockedAmount (PAV1 acc) = V0.getLockedAmount acc accountLockedAmount (PAV2 acc) = V1.getLockedAmount acc @@ -155,14 +156,14 @@ accountLockedAmount (PAV3 acc) = V1.getLockedAmount acc -- | Get the current public account available balance. -- This accounts for lock-up and staked amounts. -- @available = total - max locked staked@ -accountAvailableAmount :: (MonadBlobStore m) => PersistentAccount av -> m Amount +accountAvailableAmount :: (MonadBlobStore m) => PersistentAccount (MBSStore m) av -> m Amount accountAvailableAmount (PAV0 acc) = V0.getAvailableAmount acc accountAvailableAmount (PAV1 acc) = V0.getAvailableAmount acc accountAvailableAmount (PAV2 acc) = V1.getAvailableAmount acc accountAvailableAmount (PAV3 acc) = V1.getAvailableAmount acc -- | Get the next account nonce for transactions from this account. -accountNonce :: (MonadBlobStore m) => PersistentAccount av -> m Nonce +accountNonce :: (MonadBlobStore m) => PersistentAccount (MBSStore m) av -> m Nonce accountNonce (PAV0 acc) = V0.getNonce acc accountNonce (PAV1 acc) = V0.getNonce acc accountNonce (PAV2 acc) = V1.getNonce acc @@ -173,7 +174,7 @@ accountNonce (PAV3 acc) = V1.getNonce acc -- * For 'AllowedEncryptedTransfers' the account may only have 1 credential. -- -- * For 'AllowedMultipleCredentials' the account must have the empty encrypted balance. -accountIsAllowed :: (MonadBlobStore m) => PersistentAccount av -> AccountAllowance -> m Bool +accountIsAllowed :: (MonadBlobStore m) => PersistentAccount (MBSStore m) av -> AccountAllowance -> m Bool accountIsAllowed (PAV0 acc) = V0.isAllowed acc accountIsAllowed (PAV1 acc) = V0.isAllowed acc accountIsAllowed (PAV2 acc) = V1.isAllowed acc @@ -181,91 +182,91 @@ accountIsAllowed (PAV3 acc) = V1.isAllowed acc -- | Get the credentials deployed on the account. This map is always non-empty and (presently) -- will have a credential at index 'initialCredentialIndex' (0) that cannot be changed. -accountCredentials :: (MonadBlobStore m) => PersistentAccount av -> m (Map.Map CredentialIndex RawAccountCredential) +accountCredentials :: (MonadBlobStore m) => PersistentAccount (MBSStore m) av -> m (Map.Map CredentialIndex RawAccountCredential) accountCredentials (PAV0 acc) = V0.getCredentials acc accountCredentials (PAV1 acc) = V0.getCredentials acc accountCredentials (PAV2 acc) = V1.getCredentials acc accountCredentials (PAV3 acc) = V1.getCredentials acc -- | Get the key used to verify transaction signatures, it records the signature scheme used as well. -accountVerificationKeys :: (MonadBlobStore m) => PersistentAccount av -> m AccountInformation +accountVerificationKeys :: (MonadBlobStore m) => PersistentAccount (MBSStore m) av -> m AccountInformation accountVerificationKeys (PAV0 acc) = V0.getVerificationKeys acc accountVerificationKeys (PAV1 acc) = V0.getVerificationKeys acc accountVerificationKeys (PAV2 acc) = V1.getVerificationKeys acc accountVerificationKeys (PAV3 acc) = V1.getVerificationKeys acc -- | Get the current encrypted amount on the account. -accountEncryptedAmount :: (MonadBlobStore m) => PersistentAccount av -> m AccountEncryptedAmount +accountEncryptedAmount :: (MonadBlobStore m) => PersistentAccount (MBSStore m) av -> m AccountEncryptedAmount accountEncryptedAmount (PAV0 acc) = V0.getEncryptedAmount acc accountEncryptedAmount (PAV1 acc) = V0.getEncryptedAmount acc accountEncryptedAmount (PAV2 acc) = V1.getEncryptedAmount acc accountEncryptedAmount (PAV3 acc) = V1.getEncryptedAmount acc -- | Get the public key used to receive encrypted amounts. -accountEncryptionKey :: (MonadBlobStore m) => PersistentAccount av -> m AccountEncryptionKey +accountEncryptionKey :: (MonadBlobStore m) => PersistentAccount (MBSStore m) av -> m AccountEncryptionKey accountEncryptionKey (PAV0 acc) = V0.getEncryptionKey acc accountEncryptionKey (PAV1 acc) = V0.getEncryptionKey acc accountEncryptionKey (PAV2 acc) = V1.getEncryptionKey acc accountEncryptionKey (PAV3 acc) = V1.getEncryptionKey acc -- | Get the 'AccountReleaseSummary' summarising scheduled releases for an account. -accountReleaseSummary :: (MonadBlobStore m) => PersistentAccount av -> m AccountReleaseSummary +accountReleaseSummary :: (MonadBlobStore m) => PersistentAccount (MBSStore m) av -> m AccountReleaseSummary accountReleaseSummary (PAV0 acc) = V0.getReleaseSummary acc accountReleaseSummary (PAV1 acc) = V0.getReleaseSummary acc accountReleaseSummary (PAV2 acc) = V1.getReleaseSummary acc accountReleaseSummary (PAV3 acc) = V1.getReleaseSummary acc -- | Get the timestamp at which the next scheduled release will occur (if any). -accountNextReleaseTimestamp :: (MonadBlobStore m) => PersistentAccount av -> m (Maybe Timestamp) +accountNextReleaseTimestamp :: (MonadBlobStore m) => PersistentAccount (MBSStore m) av -> m (Maybe Timestamp) accountNextReleaseTimestamp (PAV0 acc) = V0.getNextReleaseTimestamp acc accountNextReleaseTimestamp (PAV1 acc) = V0.getNextReleaseTimestamp acc accountNextReleaseTimestamp (PAV2 acc) = V1.getNextReleaseTimestamp acc accountNextReleaseTimestamp (PAV3 acc) = V1.getNextReleaseTimestamp acc -- | Get the baker (if any) attached to an account. -accountBaker :: (MonadBlobStore m) => PersistentAccount av -> m (Maybe (AccountBaker av)) +accountBaker :: (MonadBlobStore m) => PersistentAccount (MBSStore m) av -> m (Maybe (AccountBaker av)) accountBaker (PAV0 acc) = V0.getBaker acc accountBaker (PAV1 acc) = V0.getBaker acc accountBaker (PAV2 acc) = V1.getBaker acc accountBaker (PAV3 acc) = V1.getBaker acc -- | Get a reference to the baker info (if any) attached to an account. -accountBakerInfoRef :: (MonadBlobStore m) => PersistentAccount av -> m (Maybe (PersistentBakerInfoRef av)) +accountBakerInfoRef :: (MonadBlobStore m) => PersistentAccount (MBSStore m) av -> m (Maybe (PersistentBakerInfoRef (MBSStore m) av)) accountBakerInfoRef (PAV0 acc) = fmap PBIRV0 <$> V0.getBakerInfoRef acc accountBakerInfoRef (PAV1 acc) = fmap PBIRV1 <$> V0.getBakerInfoRef acc accountBakerInfoRef (PAV2 acc) = fmap PBIRV2 <$> V1.getBakerInfoRef acc accountBakerInfoRef (PAV3 acc) = fmap PBIRV3 <$> V1.getBakerInfoRef acc -- | Get the baker and baker info reference (if any) attached to the account. -accountBakerAndInfoRef :: (MonadBlobStore m) => PersistentAccount av -> m (Maybe (AccountBaker av, PersistentBakerInfoRef av)) +accountBakerAndInfoRef :: (MonadBlobStore m) => PersistentAccount (MBSStore m) av -> m (Maybe (AccountBaker av, PersistentBakerInfoRef (MBSStore m) av)) accountBakerAndInfoRef (PAV0 acc) = fmap (second PBIRV0) <$> V0.getBakerAndInfoRef acc accountBakerAndInfoRef (PAV1 acc) = fmap (second PBIRV1) <$> V0.getBakerAndInfoRef acc accountBakerAndInfoRef (PAV2 acc) = fmap (second PBIRV2) <$> V1.getBakerAndInfoRef acc accountBakerAndInfoRef (PAV3 acc) = fmap (second PBIRV3) <$> V1.getBakerAndInfoRef acc -- | Get the delegator (if any) attached to the account. -accountDelegator :: (MonadBlobStore m) => PersistentAccount av -> m (Maybe (AccountDelegation av)) +accountDelegator :: (MonadBlobStore m) => PersistentAccount (MBSStore m) av -> m (Maybe (AccountDelegation av)) accountDelegator (PAV0 acc) = V0.getDelegator acc accountDelegator (PAV1 acc) = V0.getDelegator acc accountDelegator (PAV2 acc) = V1.getDelegator acc accountDelegator (PAV3 acc) = V1.getDelegator acc -- | Get the baker or stake delegation information attached to an account. -accountStake :: (MonadBlobStore m) => PersistentAccount av -> m (AccountStake av) +accountStake :: (MonadBlobStore m) => PersistentAccount (MBSStore m) av -> m (AccountStake av) accountStake (PAV0 acc) = V0.getStake acc accountStake (PAV1 acc) = V0.getStake acc accountStake (PAV2 acc) = V1.getStake acc accountStake (PAV3 acc) = V1.getStake acc -- | Determine if an account has stake as a baker or delegator. -accountHasActiveStake :: PersistentAccount av -> Bool +accountHasActiveStake :: PersistentAccount store av -> Bool accountHasActiveStake (PAV0 acc) = V0.hasActiveStake acc accountHasActiveStake (PAV1 acc) = V0.hasActiveStake acc accountHasActiveStake (PAV2 acc) = V1.hasActiveStake acc accountHasActiveStake (PAV3 acc) = V1.hasActiveStake acc -- | Get details about an account's stake. -accountStakeDetails :: (MonadBlobStore m) => PersistentAccount av -> m (StakeDetails av) +accountStakeDetails :: (MonadBlobStore m) => PersistentAccount (MBSStore m) av -> m (StakeDetails av) accountStakeDetails (PAV0 acc) = V0.getStakeDetails acc accountStakeDetails (PAV1 acc) = V0.getStakeDetails acc accountStakeDetails (PAV2 acc) = V1.getStakeDetails acc @@ -275,21 +276,21 @@ accountStakeDetails (PAV3 acc) = V1.getStakeDetails acc -- support flexible cooldowns. accountCooldowns :: (MonadBlobStore m, AVSupportsFlexibleCooldown av) => - PersistentAccount av -> + PersistentAccount (MBSStore m) av -> m (Maybe Cooldowns) accountCooldowns (PAV3 acc) = V1.getCooldowns acc -- | Determine if an account has a pre-pre-cooldown. accountHasPrePreCooldown :: (MonadBlobStore m, AVSupportsFlexibleCooldown av) => - PersistentAccount av -> + PersistentAccount (MBSStore m) av -> m Bool accountHasPrePreCooldown = fmap check . accountCooldowns where check = maybe False (not . null . prePreCooldown) -- | Get the 'AccountHash' for the account. -accountHash :: (MonadBlobStore m) => PersistentAccount av -> m (AccountHash av) +accountHash :: (MonadBlobStore m) => PersistentAccount (MBSStore m) av -> m (AccountHash av) accountHash (PAV0 acc) = getHashM acc accountHash (PAV1 acc) = getHashM acc accountHash (PAV2 acc) = getHashM acc @@ -298,21 +299,21 @@ accountHash (PAV3 acc) = getHashM acc -- ** 'PersistentBakerInfoRef' queries -- | Load 'BakerInfo' from a 'PersistentBakerInfoRef'. -loadBakerInfo :: (MonadBlobStore m) => PersistentBakerInfoRef av -> m BakerInfo +loadBakerInfo :: (MonadBlobStore m) => PersistentBakerInfoRef (MBSStore m) av -> m BakerInfo loadBakerInfo (PBIRV0 bir) = V0.loadBakerInfo bir loadBakerInfo (PBIRV1 bir) = V0.loadBakerInfo bir loadBakerInfo (PBIRV2 bir) = V1.loadBakerInfo bir loadBakerInfo (PBIRV3 bir) = V1.loadBakerInfo bir -- | Load 'BakerInfoEx' from a 'PersistentBakerInfoRef'. -loadPersistentBakerInfoRef :: (MonadBlobStore m) => PersistentBakerInfoRef av -> m (BakerInfoEx av) +loadPersistentBakerInfoRef :: (MonadBlobStore m) => PersistentBakerInfoRef (MBSStore m) av -> m (BakerInfoEx av) loadPersistentBakerInfoRef (PBIRV0 bir) = V0.loadPersistentBakerInfoEx bir loadPersistentBakerInfoRef (PBIRV1 bir) = V0.loadPersistentBakerInfoEx bir loadPersistentBakerInfoRef (PBIRV2 bir) = V1.loadPersistentBakerInfoEx bir loadPersistentBakerInfoRef (PBIRV3 bir) = V1.loadPersistentBakerInfoEx bir -- | Load the 'BakerId' from a 'PersistentBakerInfoRef'. -loadBakerId :: (MonadBlobStore m) => PersistentBakerInfoRef av -> m BakerId +loadBakerId :: (MonadBlobStore m) => PersistentBakerInfoRef (MBSStore m) av -> m BakerId loadBakerId (PBIRV0 bir) = V0.loadBakerId bir loadBakerId (PBIRV1 bir) = V0.loadBakerId bir loadBakerId (PBIRV2 bir) = V1.loadBakerId bir @@ -321,7 +322,7 @@ loadBakerId (PBIRV3 bir) = V1.loadBakerId bir -- * Updates -- | Apply an account update to an account. -updateAccount :: (MonadBlobStore m) => AccountUpdate -> PersistentAccount av -> m (PersistentAccount av) +updateAccount :: (MonadBlobStore m) => AccountUpdate -> PersistentAccount (MBSStore m) av -> m (PersistentAccount (MBSStore m) av) updateAccount upd (PAV0 acc) = PAV0 <$> V0.updateAccount upd acc updateAccount upd (PAV1 acc) = PAV1 <$> V0.updateAccount upd acc updateAccount upd (PAV2 acc) = PAV2 <$> V1.updateAccount upd acc @@ -344,8 +345,8 @@ updateAccountCredentials :: -- | New account threshold AccountThreshold -> -- | Account to update - PersistentAccount av -> - m (PersistentAccount av) + PersistentAccount (MBSStore m) av -> + m (PersistentAccount (MBSStore m) av) updateAccountCredentials cuRemove cuAdd cuAccountThreshold (PAV0 acc) = PAV0 <$> V0.updateAccountCredentials cuRemove cuAdd cuAccountThreshold acc updateAccountCredentials cuRemove cuAdd cuAccountThreshold (PAV1 acc) = @@ -364,8 +365,8 @@ updateAccountCredentialKeys :: -- | New public keys CredentialPublicKeys -> -- | Account to update - PersistentAccount av -> - m (PersistentAccount av) + PersistentAccount (MBSStore m) av -> + m (PersistentAccount (MBSStore m) av) updateAccountCredentialKeys credIndex credKeys (PAV0 acc) = PAV0 <$> V0.updateAccountCredentialKeys credIndex credKeys acc updateAccountCredentialKeys credIndex credKeys (PAV1 acc) = @@ -376,7 +377,7 @@ updateAccountCredentialKeys credIndex credKeys (PAV3 acc) = PAV3 <$> V1.updateAccountCredentialKeys credIndex credKeys acc -- | Add an amount to the account's balance. -addAccountAmount :: (MonadBlobStore m) => Amount -> PersistentAccount av -> m (PersistentAccount av) +addAccountAmount :: (MonadBlobStore m) => Amount -> PersistentAccount (MBSStore m) av -> m (PersistentAccount (MBSStore m) av) addAccountAmount amt (PAV0 acc) = PAV0 <$> V0.addAmount amt acc addAccountAmount amt (PAV1 acc) = PAV1 <$> V0.addAmount amt acc addAccountAmount amt (PAV2 acc) = PAV2 <$> V1.addAmount amt acc @@ -385,12 +386,12 @@ addAccountAmount amt (PAV3 acc) = PAV3 <$> V1.addAmount amt acc -- | Applies a pending stake change to an account. The account MUST have a pending stake change. -- If the account does not have a pending stake change, or is not staking, then this will raise -- an error. -applyPendingStakeChange :: (MonadBlobStore m) => PersistentAccount 'AccountV0 -> m (PersistentAccount 'AccountV0) +applyPendingStakeChange :: (MonadBlobStore m) => PersistentAccount (MBSStore m) 'AccountV0 -> m (PersistentAccount (MBSStore m) 'AccountV0) applyPendingStakeChange (PAV0 acc) = PAV0 <$> V0.applyPendingStakeChange acc -- | Add an account baker in account version 0. -- This will replace any existing staking information on the account. -addAccountBakerV0 :: (MonadBlobStore m) => BakerId -> BakerAdd -> PersistentAccount 'AccountV0 -> m (PersistentAccount 'AccountV0) +addAccountBakerV0 :: (MonadBlobStore m) => BakerId -> BakerAdd -> PersistentAccount (MBSStore m) 'AccountV0 -> m (PersistentAccount (MBSStore m) 'AccountV0) addAccountBakerV0 bid ab (PAV0 acc) = PAV0 <$> V0.addBakerV0 bid ab acc -- | Add a baker to an account for account version 1. @@ -404,8 +405,8 @@ addAccountBakerV1 :: -- | Whether earnings are restaked Bool -> -- | Account to add baker to - PersistentAccount av -> - m (PersistentAccount av) + PersistentAccount (MBSStore m) av -> + m (PersistentAccount (MBSStore m) av) addAccountBakerV1 binfo amt restake (PAV1 acc) = PAV1 <$> V0.addBakerV1 binfo amt restake acc addAccountBakerV1 binfo amt restake (PAV2 acc) = PAV2 <$> V1.addBakerV1 binfo amt restake acc addAccountBakerV1 binfo amt restake (PAV3 acc) = PAV3 <$> V1.addBakerV1 binfo amt restake acc @@ -415,8 +416,8 @@ addAccountBakerV1 binfo amt restake (PAV3 acc) = PAV3 <$> V1.addBakerV1 binfo am addAccountDelegator :: (MonadBlobStore m, AVSupportsDelegation av) => AccountDelegation av -> - PersistentAccount av -> - m (PersistentAccount av) + PersistentAccount (MBSStore m) av -> + m (PersistentAccount (MBSStore m) av) addAccountDelegator del (PAV1 acc) = PAV1 <$> V0.addDelegator del acc addAccountDelegator del (PAV2 acc) = PAV2 <$> V1.addDelegator del acc addAccountDelegator del (PAV3 acc) = PAV3 <$> V1.addDelegator del acc @@ -426,8 +427,8 @@ addAccountDelegator del (PAV3 acc) = PAV3 <$> V1.addDelegator del acc updateAccountBakerPoolInfo :: (MonadBlobStore m, AVSupportsDelegation av) => BakerPoolInfoUpdate -> - PersistentAccount av -> - m (PersistentAccount av) + PersistentAccount (MBSStore m) av -> + m (PersistentAccount (MBSStore m) av) updateAccountBakerPoolInfo upd (PAV1 acc) = PAV1 <$> V0.updateBakerPoolInfo upd acc updateAccountBakerPoolInfo upd (PAV2 acc) = PAV2 <$> V1.updateBakerPoolInfo upd acc updateAccountBakerPoolInfo upd (PAV3 acc) = PAV3 <$> V1.updateBakerPoolInfo upd acc @@ -437,8 +438,8 @@ updateAccountBakerPoolInfo upd (PAV3 acc) = PAV3 <$> V1.updateBakerPoolInfo upd setAccountBakerKeys :: (MonadBlobStore m) => BakerKeyUpdate -> - PersistentAccount av -> - m (PersistentAccount av) + PersistentAccount (MBSStore m) av -> + m (PersistentAccount (MBSStore m) av) setAccountBakerKeys keys (PAV0 acc) = PAV0 <$> V0.setBakerKeys keys acc setAccountBakerKeys keys (PAV1 acc) = PAV1 <$> V0.setBakerKeys keys acc setAccountBakerKeys keys (PAV2 acc) = PAV2 <$> V1.setBakerKeys keys acc @@ -450,8 +451,8 @@ setAccountBakerKeys keys (PAV3 acc) = PAV3 <$> V1.setBakerKeys keys acc setAccountStake :: (MonadBlobStore m) => Amount -> - PersistentAccount av -> - m (PersistentAccount av) + PersistentAccount (MBSStore m) av -> + m (PersistentAccount (MBSStore m) av) setAccountStake newStake (PAV0 acc) = PAV0 <$> V0.setStake newStake acc setAccountStake newStake (PAV1 acc) = PAV1 <$> V0.setStake newStake acc setAccountStake newStake (PAV2 acc) = PAV2 <$> V1.setStake newStake acc @@ -461,8 +462,8 @@ setAccountStake newStake (PAV3 acc) = PAV3 <$> V1.setStake newStake acc addAccountPrePreCooldown :: (MonadBlobStore m, AVSupportsFlexibleCooldown av) => Amount -> - PersistentAccount av -> - m (PersistentAccount av) + PersistentAccount (MBSStore m) av -> + m (PersistentAccount (MBSStore m) av) addAccountPrePreCooldown amt (PAV3 acc) = PAV3 <$> V1.addPrePreCooldown amt acc -- | Remove up to the given amount from the cooldowns, starting with pre-pre-cooldown, then @@ -470,8 +471,8 @@ addAccountPrePreCooldown amt (PAV3 acc) = PAV3 <$> V1.addPrePreCooldown amt acc reactivateCooldownAmount :: (MonadBlobStore m, AVSupportsFlexibleCooldown av) => Amount -> - PersistentAccount av -> - m (PersistentAccount av) + PersistentAccount (MBSStore m) av -> + m (PersistentAccount (MBSStore m) av) reactivateCooldownAmount amt (PAV3 acc) = PAV3 <$> V1.reactivateCooldownAmount amt acc -- | Set whether a baker or delegator account restakes its earnings. @@ -479,8 +480,8 @@ reactivateCooldownAmount amt (PAV3 acc) = PAV3 <$> V1.reactivateCooldownAmount a setAccountRestakeEarnings :: (MonadBlobStore m) => Bool -> - PersistentAccount av -> - m (PersistentAccount av) + PersistentAccount (MBSStore m) av -> + m (PersistentAccount (MBSStore m) av) setAccountRestakeEarnings restake (PAV0 acc) = PAV0 <$> V0.setRestakeEarnings restake acc setAccountRestakeEarnings restake (PAV1 acc) = PAV1 <$> V0.setRestakeEarnings restake acc setAccountRestakeEarnings restake (PAV2 acc) = PAV2 <$> V1.setRestakeEarnings restake acc @@ -491,8 +492,8 @@ setAccountRestakeEarnings restake (PAV3 acc) = PAV3 <$> V1.setRestakeEarnings re setAccountStakePendingChange :: (MonadBlobStore m) => StakePendingChange av -> - PersistentAccount av -> - m (PersistentAccount av) + PersistentAccount (MBSStore m) av -> + m (PersistentAccount (MBSStore m) av) setAccountStakePendingChange pc (PAV0 acc) = PAV0 <$> V0.setStakePendingChange pc acc setAccountStakePendingChange pc (PAV1 acc) = PAV1 <$> V0.setStakePendingChange pc acc setAccountStakePendingChange pc (PAV2 acc) = PAV2 <$> V1.setStakePendingChange pc acc @@ -503,8 +504,8 @@ setAccountStakePendingChange pc (PAV3 acc) = PAV3 <$> V1.setStakePendingChange p setAccountDelegationTarget :: (MonadBlobStore m) => DelegationTarget -> - PersistentAccount av -> - m (PersistentAccount av) + PersistentAccount (MBSStore m) av -> + m (PersistentAccount (MBSStore m) av) setAccountDelegationTarget target (PAV0 acc) = PAV0 <$> V0.setDelegationTarget target acc setAccountDelegationTarget target (PAV1 acc) = PAV1 <$> V0.setDelegationTarget target acc setAccountDelegationTarget target (PAV2 acc) = PAV2 <$> V1.setDelegationTarget target acc @@ -513,8 +514,8 @@ setAccountDelegationTarget target (PAV3 acc) = PAV3 <$> V1.setDelegationTarget t -- | Remove any staking on an account. removeAccountStaking :: (MonadBlobStore m) => - PersistentAccount av -> - m (PersistentAccount av) + PersistentAccount (MBSStore m) av -> + m (PersistentAccount (MBSStore m) av) removeAccountStaking (PAV0 acc) = PAV0 <$> V0.removeStaking acc removeAccountStaking (PAV1 acc) = PAV1 <$> V0.removeStaking acc removeAccountStaking (PAV2 acc) = PAV2 <$> V1.removeStaking acc @@ -525,8 +526,8 @@ removeAccountStaking (PAV3 acc) = PAV3 <$> V1.removeStaking acc setAccountCommissionRates :: (MonadBlobStore m, AVSupportsDelegation av) => CommissionRates -> - PersistentAccount av -> - m (PersistentAccount av) + PersistentAccount (MBSStore m) av -> + m (PersistentAccount (MBSStore m) av) setAccountCommissionRates rates (PAV1 acc) = PAV1 <$> V0.setCommissionRates rates acc setAccountCommissionRates rates (PAV2 acc) = PAV2 <$> V1.setCommissionRates rates acc setAccountCommissionRates rates (PAV3 acc) = PAV3 <$> V1.setCommissionRates rates acc @@ -537,8 +538,8 @@ setAccountCommissionRates rates (PAV3 acc) = PAV3 <$> V1.setCommissionRates rate unlockAccountReleases :: (MonadBlobStore m) => Timestamp -> - PersistentAccount av -> - m (Maybe Timestamp, PersistentAccount av) + PersistentAccount (MBSStore m) av -> + m (Maybe Timestamp, PersistentAccount (MBSStore m) av) unlockAccountReleases ts (PAV0 acc) = second PAV0 <$> V0.unlockReleases ts acc unlockAccountReleases ts (PAV1 acc) = second PAV1 <$> V0.unlockReleases ts acc unlockAccountReleases ts (PAV2 acc) = second PAV2 <$> V1.unlockReleases ts acc @@ -549,8 +550,8 @@ unlockAccountReleases ts (PAV3 acc) = second PAV3 <$> V1.unlockReleases ts acc processAccountCooldownsUntil :: (MonadBlobStore m, AVSupportsFlexibleCooldown av) => Timestamp -> - PersistentAccount av -> - m (Maybe Timestamp, PersistentAccount av) + PersistentAccount (MBSStore m) av -> + m (Maybe Timestamp, PersistentAccount (MBSStore m) av) processAccountCooldownsUntil ts (PAV3 acc) = second PAV3 <$> V1.processCooldownsUntil ts acc @@ -561,8 +562,8 @@ processAccountCooldownsUntil ts (PAV3 acc) = processAccountPreCooldown :: (MonadBlobStore m, AVSupportsFlexibleCooldown av) => Timestamp -> - PersistentAccount av -> - m (NextCooldownChange, PersistentAccount av) + PersistentAccount (MBSStore m) av -> + m (NextCooldownChange, PersistentAccount (MBSStore m) av) processAccountPreCooldown ts (PAV3 acc) = second PAV3 <$> V1.processPreCooldown ts acc -- | Move the pre-pre-cooldown amount on an account into pre-cooldown. @@ -571,8 +572,8 @@ processAccountPreCooldown ts (PAV3 acc) = second PAV3 <$> V1.processPreCooldown -- a pre-cooldown amount, the pre-pre-cooldown amount will be added to it. processAccountPrePreCooldown :: (MonadBlobStore m, AVSupportsFlexibleCooldown av) => - PersistentAccount av -> - m (PersistentAccount av) + PersistentAccount (MBSStore m) av -> + m (PersistentAccount (MBSStore m) av) processAccountPrePreCooldown (PAV3 acc) = PAV3 <$> V1.processPrePreCooldown acc -- * Creation @@ -582,7 +583,7 @@ makePersistentAccount :: forall m av. (MonadBlobStore m, IsAccountVersion av) => Transient.Account av -> - m (PersistentAccount av) + m (PersistentAccount (MBSStore m) av) makePersistentAccount tacc = case accountVersion @av of SAccountV0 -> PAV0 <$> V0.makePersistentAccount tacc SAccountV1 -> PAV1 <$> V0.makePersistentAccount tacc @@ -596,7 +597,7 @@ newAccount :: GlobalContext -> AccountAddress -> AccountCredential -> - m (PersistentAccount av) + m (PersistentAccount (MBSStore m) av) newAccount = case accountVersion @av of SAccountV0 -> \ctx addr cred -> PAV0 <$> V0.newAccount ctx addr cred SAccountV1 -> \ctx addr cred -> PAV1 <$> V0.newAccount ctx addr cred @@ -612,7 +613,7 @@ makeFromGenesisAccount :: GlobalContext -> ChainParameters pv -> GenesisAccount -> - m (PersistentAccount av) + m (PersistentAccount (MBSStore m) av) makeFromGenesisAccount spv = case accountVersion @av of SAccountV0 -> \cryptoParams chainParameters genesisAccount -> @@ -631,7 +632,7 @@ makePersistentBakerInfoRef :: forall av m. (IsAccountVersion av, MonadBlobStore m) => BakerInfoEx av -> - m (PersistentBakerInfoRef av) + m (PersistentBakerInfoRef (MBSStore m) av) makePersistentBakerInfoRef = case accountVersion @av of SAccountV0 -> fmap PBIRV0 . V0.makePersistentBakerInfoEx SAccountV1 -> fmap PBIRV1 . V0.makePersistentBakerInfoEx @@ -664,8 +665,8 @@ migratePersistentAccount :: MonadLogger (t m) ) => StateMigrationParameters oldpv pv -> - PersistentAccount (AccountVersionFor oldpv) -> - t m (PersistentAccount (AccountVersionFor pv)) + PersistentAccount (MBSStore m) (AccountVersionFor oldpv) -> + t m (PersistentAccount (MBSStore (t m)) (AccountVersionFor pv)) migratePersistentAccount m@StateMigrationParametersTrivial (PAV0 acc) = PAV0 <$> V0.migratePersistentAccount m acc migratePersistentAccount m@StateMigrationParametersTrivial (PAV1 acc) = PAV1 <$> V0.migratePersistentAccount m acc migratePersistentAccount m@StateMigrationParametersTrivial (PAV2 acc) = PAV2 <$> V1.migratePersistentAccount m acc @@ -682,8 +683,8 @@ migratePersistentBakerInfoRef :: forall oldpv pv t m. (IsProtocolVersion pv, SupportMigration m t) => StateMigrationParameters oldpv pv -> - PersistentBakerInfoRef (AccountVersionFor oldpv) -> - t m (PersistentBakerInfoRef (AccountVersionFor pv)) + PersistentBakerInfoRef (MBSStore m) (AccountVersionFor oldpv) -> + t m (PersistentBakerInfoRef (MBSStore (t m)) (AccountVersionFor pv)) migratePersistentBakerInfoRef m@StateMigrationParametersTrivial (PBIRV0 bir) = PBIRV0 <$> V0.migratePersistentBakerInfoEx m bir migratePersistentBakerInfoRef m@StateMigrationParametersTrivial (PBIRV1 bir) = PBIRV1 <$> V0.migratePersistentBakerInfoEx m bir migratePersistentBakerInfoRef m@StateMigrationParametersTrivial (PBIRV2 bir) = PBIRV2 <$> V1.migratePersistentBakerInfoEx m bir @@ -698,7 +699,7 @@ migratePersistentBakerInfoRef m@StateMigrationParametersP6ToP7{} (PBIRV2 bir) = -- * Conversion -- | Converts an account to a transient (i.e. in memory) account. (Used for testing.) -toTransientAccount :: (MonadBlobStore m) => PersistentAccount av -> m (Transient.Account av) +toTransientAccount :: (MonadBlobStore m) => PersistentAccount (MBSStore m) av -> m (Transient.Account av) toTransientAccount (PAV0 acc) = V0.toTransientAccount acc toTransientAccount (PAV1 acc) = V0.toTransientAccount acc toTransientAccount (PAV2 acc) = V1.toTransientAccount acc diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Account/CooldownQueue.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Account/CooldownQueue.hs index a9bece6399..20b39e8efd 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Account/CooldownQueue.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Account/CooldownQueue.hs @@ -26,19 +26,19 @@ import Concordium.GlobalState.Persistent.BlobStore -- | A 'CooldownQueue' records the inactive stake amounts that are due to be released in future. -- Note that prior to account version 3 (protocol version 7), the only value is the empty cooldown -- queue. -data CooldownQueue (av :: AccountVersion) where +data CooldownQueue store (av :: AccountVersion) where -- | The empty cooldown queue. - EmptyCooldownQueue :: CooldownQueue av + EmptyCooldownQueue :: CooldownQueue store av -- | A non-empty cooldown queue. -- INVARIANT: The 'Cooldowns' must not satisfy 'isEmptyCooldowns'. CooldownQueue :: (AVSupportsFlexibleCooldown av) => - !(EagerBufferedRef Cooldowns) -> - CooldownQueue av + !(EagerBufferedRef store Cooldowns) -> + CooldownQueue store av -deriving instance Show (CooldownQueue av) +deriving instance Show (CooldownQueue store av) -instance forall m av. (MonadBlobStore m, IsAccountVersion av) => BlobStorable m (CooldownQueue av) where +instance forall m store av. (MonadBlobStore m, store ~ MBSStore m, IsAccountVersion av) => BlobStorable m (CooldownQueue store av) where load = case sSupportsFlexibleCooldown (accountVersion @av) of SFalse -> return $ return EmptyCooldownQueue STrue -> do @@ -53,7 +53,7 @@ instance forall m av. (MonadBlobStore m, IsAccountVersion av) => BlobStorable m (putter, nRef) <- storeUpdate (asNullable queue) return $!! (putter, ofNullable nRef) where - asNullable :: CooldownQueue av -> Nullable (EagerBufferedRef Cooldowns) + asNullable :: CooldownQueue store av -> Nullable (EagerBufferedRef store Cooldowns) asNullable EmptyCooldownQueue = Null asNullable (CooldownQueue queue) = Some queue ofNullable Null = EmptyCooldownQueue @@ -64,16 +64,16 @@ emptyCooldownQueueHash :: CooldownQueueHash av {-# NOINLINE emptyCooldownQueueHash #-} emptyCooldownQueueHash = CooldownQueueHash (getHash emptyCooldowns) -instance (MonadBlobStore m) => MHashableTo m (CooldownQueueHash av) (CooldownQueue av) where +instance (MonadBlobStore m, store ~ MBSStore m) => MHashableTo m (CooldownQueueHash av) (CooldownQueue store av) where getHashM EmptyCooldownQueue = return emptyCooldownQueueHash getHashM (CooldownQueue ref) = CooldownQueueHash . getHash <$> refLoad ref -- | The empty 'CooldownQueue'. -emptyCooldownQueue :: CooldownQueue av +emptyCooldownQueue :: CooldownQueue store av emptyCooldownQueue = EmptyCooldownQueue -- | Check if a 'CooldownQueue' is empty. -isCooldownQueueEmpty :: CooldownQueue av -> Bool +isCooldownQueueEmpty :: CooldownQueue store av -> Bool isCooldownQueueEmpty EmptyCooldownQueue = True isCooldownQueueEmpty _ = False @@ -81,7 +81,7 @@ isCooldownQueueEmpty _ = False makeCooldownQueue :: (MonadBlobStore m, AVSupportsFlexibleCooldown av) => Cooldowns -> - m (CooldownQueue av) + m (CooldownQueue (MBSStore m) av) makeCooldownQueue cooldowns | isEmptyCooldowns cooldowns = return EmptyCooldownQueue | otherwise = CooldownQueue <$> refMake cooldowns @@ -90,15 +90,15 @@ makeCooldownQueue cooldowns makePersistentCooldownQueue :: (MonadBlobStore m) => Conditionally (SupportsFlexibleCooldown av) Cooldowns -> - m (CooldownQueue av) + m (CooldownQueue (MBSStore m) av) makePersistentCooldownQueue CFalse = return EmptyCooldownQueue makePersistentCooldownQueue (CTrue cooldowns) = makeCooldownQueue cooldowns -- | Convert a 'CooldownQueue' to representation used for transient accounts. toTransientCooldownQueue :: - forall av. + forall av store. (IsAccountVersion av) => - CooldownQueue av -> + CooldownQueue store av -> Conditionally (SupportsFlexibleCooldown av) Cooldowns toTransientCooldownQueue = case sSupportsFlexibleCooldown (accountVersion @av) of SFalse -> const CFalse @@ -112,7 +112,7 @@ initialPrePreCooldownQueue :: (MonadBlobStore m, AVSupportsFlexibleCooldown av) => -- | Initial amount in pre-pre-cooldown. Amount -> - m (CooldownQueue av) + m (CooldownQueue (MBSStore m) av) initialPrePreCooldownQueue target = CooldownQueue <$> refMake @@ -123,13 +123,13 @@ initialPrePreCooldownQueue target = } -- | Migrate a cooldown queue unchanged. -migrateCooldownQueue :: forall m t av. (SupportMigration m t) => CooldownQueue av -> t m (CooldownQueue av) +migrateCooldownQueue :: forall m t av. (SupportMigration m t) => CooldownQueue (MBSStore m) av -> t m (CooldownQueue (MBSStore (t m)) av) migrateCooldownQueue EmptyCooldownQueue = return EmptyCooldownQueue migrateCooldownQueue (CooldownQueue queueRef) = CooldownQueue <$> migrateEagerBufferedRef return queueRef -- | Get the total stake in cooldown, pre-cooldown and pre-pre-cooldown. -cooldownStake :: CooldownQueue av -> Amount +cooldownStake :: CooldownQueue store av -> Amount cooldownStake EmptyCooldownQueue = 0 cooldownStake (CooldownQueue queueRef) = cooldownTotal $ eagerBufferedDeref queueRef @@ -138,8 +138,8 @@ addPrePreCooldown :: (MonadBlobStore m, AVSupportsFlexibleCooldown av) => -- | The amount to add to the pre-pre-cooldown. Amount -> - CooldownQueue av -> - m (CooldownQueue av) + CooldownQueue (MBSStore m) av -> + m (CooldownQueue (MBSStore m) av) addPrePreCooldown amount EmptyCooldownQueue = initialPrePreCooldownQueue amount addPrePreCooldown amount (CooldownQueue queueRef) = do let oldCooldowns = eagerBufferedDeref queueRef @@ -152,8 +152,8 @@ reactivateCooldownAmount :: (MonadBlobStore m, AVSupportsFlexibleCooldown av) => -- | The amount to reactivate. Amount -> - CooldownQueue av -> - m (CooldownQueue av) + CooldownQueue (MBSStore m) av -> + m (CooldownQueue (MBSStore m) av) reactivateCooldownAmount _ EmptyCooldownQueue = return EmptyCooldownQueue reactivateCooldownAmount amount (CooldownQueue queueRef) = do let oldCooldowns = eagerBufferedDeref queueRef @@ -166,8 +166,8 @@ processCooldownsUntil :: (MonadBlobStore m) => -- | Release all cooldowns up to and including this timestamp. Timestamp -> - CooldownQueue av -> - m (Maybe Timestamp, CooldownQueue av) + CooldownQueue (MBSStore m) av -> + m (Maybe Timestamp, CooldownQueue (MBSStore m) av) processCooldownsUntil _ EmptyCooldownQueue = return (Nothing, EmptyCooldownQueue) processCooldownsUntil ts (CooldownQueue queueRef) = do let !newCooldowns = processCooldowns ts $ eagerBufferedDeref queueRef @@ -193,8 +193,8 @@ processPreCooldown :: (MonadBlobStore m) => -- | The timestamp at which the pre-cooldown should be released. Timestamp -> - CooldownQueue av -> - m (NextCooldownChange, CooldownQueue av) + CooldownQueue (MBSStore m) av -> + m (NextCooldownChange, CooldownQueue (MBSStore m) av) processPreCooldown _ EmptyCooldownQueue = return (NextCooldownUnchanged, EmptyCooldownQueue) processPreCooldown ts (CooldownQueue queueRef) = do let oldCooldowns = eagerBufferedDeref queueRef @@ -217,7 +217,7 @@ processPreCooldown ts (CooldownQueue queueRef) = do -- It should be the case that there is a pre-pre-cooldown amount and no pre-cooldown amount. -- However, if there is no pre-pre-cooldown amount, this will do nothing, and if there is already -- a pre-cooldown amount, the pre-pre-cooldown amount will be added to it. -processPrePreCooldown :: (MonadBlobStore m) => CooldownQueue av -> m (CooldownQueue av) +processPrePreCooldown :: (MonadBlobStore m) => CooldownQueue (MBSStore m) av -> m (CooldownQueue (MBSStore m) av) processPrePreCooldown EmptyCooldownQueue = return EmptyCooldownQueue processPrePreCooldown (CooldownQueue queueRef) = do let oldCooldowns = eagerBufferedDeref queueRef diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Account/EncryptedAmount.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Account/EncryptedAmount.hs index 6b69aa6522..166b62b1e5 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Account/EncryptedAmount.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Account/EncryptedAmount.hs @@ -25,7 +25,7 @@ import Concordium.GlobalState.Persistent.BlobStore -- loaded, the entire encrypted amount will also be loaded. -- This is useful, since the encrypted amount structure is used for computing the -- hash of the account. (See $PersistentAccountCacheable.) -data PersistentAccountEncryptedAmount = PersistentAccountEncryptedAmount +data PersistentAccountEncryptedAmount store = PersistentAccountEncryptedAmount { -- | Encrypted amount that is a result of this accounts' actions. -- In particular this list includes the aggregate of -- @@ -34,7 +34,7 @@ data PersistentAccountEncryptedAmount = PersistentAccountEncryptedAmount -- - encrypted amounts that are transferred from public balance -- -- When a transfer is made all of these must always be used. - _selfAmount :: !(EagerBufferedRef EncryptedAmount), + _selfAmount :: !(EagerBufferedRef store EncryptedAmount), -- | Starting index for incoming encrypted amounts. If an aggregated amount is present -- then this index is associated with such an amount and the list of incoming encrypted amounts -- starts at the index @_startIndex + 1@. @@ -42,16 +42,16 @@ data PersistentAccountEncryptedAmount = PersistentAccountEncryptedAmount -- | Amounts starting at @startIndex@ (or at @startIndex + 1@ if there is an aggregated amount present). -- They are assumed to be numbered sequentially. This list will never contain more than 'maxNumIncoming' -- (or @maxNumIncoming - 1@ if there is an aggregated amount present) values. - _incomingEncryptedAmounts :: !(Seq.Seq (EagerBufferedRef EncryptedAmount)), + _incomingEncryptedAmounts :: !(Seq.Seq (EagerBufferedRef store EncryptedAmount)), -- | If 'Just', the amount that has resulted from aggregating other amounts and the -- number of aggregated amounts (must be at least 2 if present). - _aggregatedAmount :: !(Maybe (EagerBufferedRef EncryptedAmount, Word32)) + _aggregatedAmount :: !(Maybe (EagerBufferedRef store EncryptedAmount, Word32)) } deriving (Show) -- | Create a PersistentAccountEncryptedAmount with the initial, 0 encrypted balance (with -- randomness 0) and no incoming amounts. -initialPersistentAccountEncryptedAmount :: (MonadBlobStore m) => m PersistentAccountEncryptedAmount +initialPersistentAccountEncryptedAmount :: (MonadBlobStore m) => m (PersistentAccountEncryptedAmount (MBSStore m)) initialPersistentAccountEncryptedAmount = do _selfAmount <- refMake mempty return $! @@ -63,7 +63,7 @@ initialPersistentAccountEncryptedAmount = do } -- | Check whether the account encrypted amount is identically the initial encrypted amount. -isInitialPersistentAccountEncryptedAmount :: (MonadBlobStore m) => PersistentAccountEncryptedAmount -> m Bool +isInitialPersistentAccountEncryptedAmount :: (MonadBlobStore m) => PersistentAccountEncryptedAmount (MBSStore m) -> m Bool isInitialPersistentAccountEncryptedAmount PersistentAccountEncryptedAmount{..} = if _startIndex == 0 && Seq.null _incomingEncryptedAmounts && isNothing _aggregatedAmount then isZeroEncryptedAmount <$> refLoad _selfAmount @@ -72,7 +72,7 @@ isInitialPersistentAccountEncryptedAmount PersistentAccountEncryptedAmount{..} = -- Checks whether the account encrypted amount is zero. This checks that there -- are no incoming amounts, and that the self amount is a specific encryption of -- 0, with randomness 0. -isZeroPersistentAccountEncryptedAmount :: (MonadBlobStore m) => PersistentAccountEncryptedAmount -> m Bool +isZeroPersistentAccountEncryptedAmount :: (MonadBlobStore m) => PersistentAccountEncryptedAmount (MBSStore m) -> m Bool isZeroPersistentAccountEncryptedAmount PersistentAccountEncryptedAmount{..} = if Seq.null _incomingEncryptedAmounts && isNothing _aggregatedAmount then isZeroEncryptedAmount <$> refLoad _selfAmount @@ -84,7 +84,7 @@ isZeroPersistentAccountEncryptedAmount PersistentAccountEncryptedAmount{..} = -- This should match the serialization format of 'AccountEncryptedAmount' exactly. putAccountEncryptedAmountV0 :: (MonadBlobStore m) => - PersistentAccountEncryptedAmount -> + PersistentAccountEncryptedAmount (MBSStore m) -> m (Maybe Put) putAccountEncryptedAmountV0 ea@PersistentAccountEncryptedAmount{..} = do isInitial <- isInitialPersistentAccountEncryptedAmount ea @@ -111,7 +111,7 @@ putAccountEncryptedAmountV0 ea@PersistentAccountEncryptedAmount{..} = do storePersistentAccountEncryptedAmount :: (MonadBlobStore m) => AccountEncryptedAmount -> - m PersistentAccountEncryptedAmount + m (PersistentAccountEncryptedAmount (MBSStore m)) storePersistentAccountEncryptedAmount AccountEncryptedAmount{..} = do _selfAmount <- refMake _selfAmount _incomingEncryptedAmounts <- mapM refMake _incomingEncryptedAmounts @@ -123,7 +123,7 @@ storePersistentAccountEncryptedAmount AccountEncryptedAmount{..} = do -- | Given a PersistentAccountEncryptedAmount, load its equivalent AccountEncryptedAmount loadPersistentAccountEncryptedAmount :: (MonadBlobStore m) => - PersistentAccountEncryptedAmount -> + PersistentAccountEncryptedAmount (MBSStore m) -> m AccountEncryptedAmount loadPersistentAccountEncryptedAmount PersistentAccountEncryptedAmount{..} = do _selfAmount <- refLoad _selfAmount @@ -133,7 +133,7 @@ loadPersistentAccountEncryptedAmount PersistentAccountEncryptedAmount{..} = do Just (e, n) -> Just . (,n) <$> refLoad e return $! AccountEncryptedAmount{..} -instance (MonadBlobStore m) => BlobStorable m PersistentAccountEncryptedAmount where +instance (MonadBlobStore m, store ~ MBSStore m) => BlobStorable m (PersistentAccountEncryptedAmount store) where storeUpdate PersistentAccountEncryptedAmount{..} = do (pSelf, _selfAmount) <- storeUpdate _selfAmount (pAmounts, _incomingEncryptedAmounts) <- Seq.unzip <$> mapM storeUpdate _incomingEncryptedAmounts @@ -170,7 +170,7 @@ instance (MonadBlobStore m) => BlobStorable m PersistentAccountEncryptedAmount w Nothing -> return Nothing return PersistentAccountEncryptedAmount{..} -instance (MonadBlobStore m) => Cacheable m PersistentAccountEncryptedAmount +instance (MonadBlobStore m) => Cacheable m (PersistentAccountEncryptedAmount store) -- | Add an encrypted amount to the end of the list. -- This is used when an incoming transfer is added to the account. If this would @@ -179,8 +179,8 @@ instance (MonadBlobStore m) => Cacheable m PersistentAccountEncryptedAmount addIncomingEncryptedAmount :: (MonadBlobStore m) => EncryptedAmount -> - PersistentAccountEncryptedAmount -> - m PersistentAccountEncryptedAmount + PersistentAccountEncryptedAmount (MBSStore m) -> + m (PersistentAccountEncryptedAmount (MBSStore m)) addIncomingEncryptedAmount !newAmount old = do !newAmountRef <- refMake newAmount case _aggregatedAmount old of @@ -228,8 +228,8 @@ replaceUpTo :: (MonadBlobStore m) => EncryptedAmountAggIndex -> EncryptedAmount -> - PersistentAccountEncryptedAmount -> - m PersistentAccountEncryptedAmount + PersistentAccountEncryptedAmount (MBSStore m) -> + m (PersistentAccountEncryptedAmount (MBSStore m)) replaceUpTo newIndex newAmount PersistentAccountEncryptedAmount{..} = do _selfAmount <- refMake newAmount return $! @@ -255,8 +255,8 @@ replaceUpTo newIndex newAmount PersistentAccountEncryptedAmount{..} = do addToSelfEncryptedAmount :: (MonadBlobStore m) => EncryptedAmount -> - PersistentAccountEncryptedAmount -> - m PersistentAccountEncryptedAmount + PersistentAccountEncryptedAmount (MBSStore m) -> + m (PersistentAccountEncryptedAmount (MBSStore m)) addToSelfEncryptedAmount newAmount old@PersistentAccountEncryptedAmount{..} = do newSelf <- refMake . (<> newAmount) =<< refLoad _selfAmount return $! old{_selfAmount = newSelf} @@ -264,8 +264,8 @@ addToSelfEncryptedAmount newAmount old@PersistentAccountEncryptedAmount{..} = do -- | See documentation of @migratePersistentBlockState@. migratePersistentEncryptedAmount :: (SupportMigration m t) => - PersistentAccountEncryptedAmount -> - t m PersistentAccountEncryptedAmount + PersistentAccountEncryptedAmount (MBSStore m) -> + t m (PersistentAccountEncryptedAmount (MBSStore (t m))) migratePersistentEncryptedAmount PersistentAccountEncryptedAmount{..} = do newSelfAmount <- migrateEagerBufferedRef return _selfAmount newIncomingEncryptedAmounts <- mapM (migrateEagerBufferedRef return) _incomingEncryptedAmounts diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Account/StructureV0.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Account/StructureV0.hs index 7531252022..8a60186ddf 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Account/StructureV0.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Account/StructureV0.hs @@ -82,26 +82,30 @@ type StructureV0 (pv :: ProtocolVersion) = AVStructureV0 (AccountVersionFor pv) -- Before delegation ('AccountV0'), there is no extra info. -- With delegation, this consists of (a reference to) the 'BakerPoolInfo'. -- (This type is always fully cached in memory. See $PersistentAccountCacheable for details.) -type family PersistentExtraBakerInfo' (av :: AccountVersion) where - PersistentExtraBakerInfo' 'AccountV0 = () - PersistentExtraBakerInfo' 'AccountV1 = EagerBufferedRef BakerPoolInfo +type family PersistentExtraBakerInfo' store (av :: AccountVersion) where + PersistentExtraBakerInfo' store 'AccountV0 = () + PersistentExtraBakerInfo' store 'AccountV1 = EagerBufferedRef store BakerPoolInfo -- | Extra info (beyond 'BakerInfo') associated with a baker. -- (This structure is always fully cached in memory. See $PersistentAccountCacheable for details.) -newtype PersistentExtraBakerInfo (av :: AccountVersion) = PersistentExtraBakerInfo - { _theExtraBakerInfo :: PersistentExtraBakerInfo' av +newtype PersistentExtraBakerInfo store (av :: AccountVersion) = PersistentExtraBakerInfo + { _theExtraBakerInfo :: PersistentExtraBakerInfo' store av } makeLenses ''PersistentExtraBakerInfo -instance forall av. (IsAccountVersion av, AVStructureV0 av) => Show (PersistentExtraBakerInfo av) where +instance forall store av. (IsAccountVersion av, AVStructureV0 av) => Show (PersistentExtraBakerInfo store av) where show = case accountVersion @av of SAccountV0 -> show . _theExtraBakerInfo SAccountV1 -> show . _theExtraBakerInfo -instance forall av m. (Applicative m) => Cacheable m (PersistentExtraBakerInfo av) +instance forall store av m. (Applicative m) => Cacheable m (PersistentExtraBakerInfo store av) -instance forall av m. (IsAccountVersion av, AVStructureV0 av, MonadBlobStore m) => BlobStorable m (PersistentExtraBakerInfo av) where +instance + forall store av m. + (IsAccountVersion av, AVStructureV0 av, MonadBlobStore m, store ~ MBSStore m) => + BlobStorable m (PersistentExtraBakerInfo store av) + where storeUpdate = fmap (second PersistentExtraBakerInfo) . ( case accountVersion @av of @@ -115,10 +119,10 @@ instance forall av m. (IsAccountVersion av, AVStructureV0 av, MonadBlobStore m) SAccountV1 -> load makePersistentExtraBakerInfoV1 :: - forall av. + forall store av. (IsAccountVersion av, AVStructureV0 av, AVSupportsDelegation av) => - EagerBufferedRef BakerPoolInfo -> - PersistentExtraBakerInfo av + EagerBufferedRef store BakerPoolInfo -> + PersistentExtraBakerInfo store av makePersistentExtraBakerInfoV1 = case accountVersion @av of SAccountV1 -> PersistentExtraBakerInfo @@ -130,8 +134,8 @@ migratePersistentExtraBakerInfo' :: SupportMigration m t ) => StateMigrationParameters oldpv pv -> - PersistentExtraBakerInfo' (AccountVersionFor oldpv) -> - t m (PersistentExtraBakerInfo' (AccountVersionFor pv)) + PersistentExtraBakerInfo' (MBSStore m) (AccountVersionFor oldpv) -> + t m (PersistentExtraBakerInfo' (MBSStore (t m)) (AccountVersionFor pv)) migratePersistentExtraBakerInfo' migration bi = do case migration of StateMigrationParametersTrivial -> @@ -153,8 +157,8 @@ migratePersistentExtraBakerInfo :: SupportMigration m t ) => StateMigrationParameters oldpv pv -> - PersistentExtraBakerInfo (AccountVersionFor oldpv) -> - t m (PersistentExtraBakerInfo (AccountVersionFor pv)) + PersistentExtraBakerInfo (MBSStore m) (AccountVersionFor oldpv) -> + t m (PersistentExtraBakerInfo (MBSStore (t m)) (AccountVersionFor pv)) migratePersistentExtraBakerInfo migration = fmap PersistentExtraBakerInfo . migratePersistentExtraBakerInfo' migration @@ -164,14 +168,18 @@ migratePersistentExtraBakerInfo migration = -- | A persistent version of 'BakerInfoEx'. -- (This structure is always fully cached in memory. See $PersistentAccountCacheable for details.) -data PersistentBakerInfoEx av = PersistentBakerInfoEx - { bakerInfoRef :: !(EagerBufferedRef BakerInfo), - bakerInfoExtra :: !(PersistentExtraBakerInfo av) +data PersistentBakerInfoEx store av = PersistentBakerInfoEx + { bakerInfoRef :: !(EagerBufferedRef store BakerInfo), + bakerInfoExtra :: !(PersistentExtraBakerInfo store av) } -deriving instance (IsAccountVersion av, AVStructureV0 av) => Show (PersistentBakerInfoEx av) +deriving instance (IsAccountVersion av, AVStructureV0 av) => Show (PersistentBakerInfoEx store av) -instance forall m av. (IsAccountVersion av, AVStructureV0 av, MonadBlobStore m) => BlobStorable m (PersistentBakerInfoEx av) where +instance + forall m store av. + (IsAccountVersion av, AVStructureV0 av, MonadBlobStore m, store ~ MBSStore m) => + BlobStorable m (PersistentBakerInfoEx store av) + where storeUpdate PersistentBakerInfoEx{..} = do (pBakerInfo, newBakerInfo) <- storeUpdate bakerInfoRef (pExtraBakerInfo, newExtraBakerInfo) <- storeUpdate bakerInfoExtra @@ -192,19 +200,19 @@ instance forall m av. (IsAccountVersion av, AVStructureV0 av, MonadBlobStore m) bakerInfoExtra <- rExtraBakerInfo return PersistentBakerInfoEx{..} -instance (Applicative m) => Cacheable m (PersistentBakerInfoEx av) +instance (Applicative m) => Cacheable m (PersistentBakerInfoEx store av) -- ** Query -- | Load 'BakerInfo' from a 'PersistentBakerInfoEx'. -loadBakerInfo :: (MonadBlobStore m) => PersistentBakerInfoEx av -> m BakerInfo +loadBakerInfo :: (MonadBlobStore m) => PersistentBakerInfoEx (MBSStore m) av -> m BakerInfo loadBakerInfo = refLoad . bakerInfoRef -- | Load a 'BakerInfoEx' from a 'PersistentBakerInfoEx'. loadPersistentBakerInfoEx :: forall av m. (IsAccountVersion av, AVStructureV0 av, MonadBlobStore m) => - PersistentBakerInfoEx av -> + PersistentBakerInfoEx (MBSStore m) av -> m (BakerInfoEx av) loadPersistentBakerInfoEx PersistentBakerInfoEx{..} = do bkrInfo <- refLoad bakerInfoRef @@ -215,7 +223,7 @@ loadPersistentBakerInfoEx PersistentBakerInfoEx{..} = do return $ BakerInfoExV1 bkrInfo bkrInfoEx -- | Load the baker id from the 'PersistentBakerInfoEx' structure. -loadBakerId :: (MonadBlobStore m) => PersistentBakerInfoEx av -> m BakerId +loadBakerId :: (MonadBlobStore m) => PersistentBakerInfoEx (MBSStore m) av -> m BakerId loadBakerId PersistentBakerInfoEx{..} = do bi <- refLoad bakerInfoRef return (_bakerIdentity bi) @@ -223,7 +231,10 @@ loadBakerId PersistentBakerInfoEx{..} = do -- ** Construction -- | Construct a 'PersistentBakerInfoEx' from a 'BakerInfoEx'. -makePersistentBakerInfoEx :: (IsAccountVersion av, AVStructureV0 av, MonadBlobStore m) => BakerInfoEx av -> m (PersistentBakerInfoEx av) +makePersistentBakerInfoEx :: + (IsAccountVersion av, AVStructureV0 av, MonadBlobStore m) => + BakerInfoEx av -> + m (PersistentBakerInfoEx (MBSStore m) av) makePersistentBakerInfoEx (BakerInfoExV0 bi) = do bakerInfoRef <- refMake bi return PersistentBakerInfoEx{bakerInfoExtra = PersistentExtraBakerInfo (), ..} @@ -242,8 +253,8 @@ migratePersistentBakerInfoEx :: SupportMigration m t ) => StateMigrationParameters oldpv pv -> - PersistentBakerInfoEx (AccountVersionFor oldpv) -> - t m (PersistentBakerInfoEx (AccountVersionFor pv)) + PersistentBakerInfoEx (MBSStore m) (AccountVersionFor oldpv) -> + t m (PersistentBakerInfoEx (MBSStore (t m)) (AccountVersionFor pv)) migratePersistentBakerInfoEx migration PersistentBakerInfoEx{..} = do newBakerInfoRef <- migrateEagerBufferedRef return bakerInfoRef newBakerInfoExtra <- migratePersistentExtraBakerInfo migration bakerInfoExtra @@ -257,19 +268,23 @@ migratePersistentBakerInfoEx migration PersistentBakerInfoEx{..} = do -- | A baker associated with an account. -- (This structure is always fully cached in memory. See $PersistentAccountCacheable for details.) -data PersistentAccountBaker (av :: AccountVersion) = PersistentAccountBaker +data PersistentAccountBaker store (av :: AccountVersion) = PersistentAccountBaker { _stakedAmount :: !Amount, _stakeEarnings :: !Bool, - _accountBakerInfo :: !(EagerBufferedRef BakerInfo), - _extraBakerInfo :: !(PersistentExtraBakerInfo av), + _accountBakerInfo :: !(EagerBufferedRef store BakerInfo), + _extraBakerInfo :: !(PersistentExtraBakerInfo store av), _bakerPendingChange :: !(StakePendingChange av) } -deriving instance (IsAccountVersion av, AVStructureV0 av) => Show (PersistentAccountBaker av) +deriving instance (IsAccountVersion av, AVStructureV0 av) => Show (PersistentAccountBaker store av) makeLenses ''PersistentAccountBaker -instance forall m av. (IsAccountVersion av, AVStructureV0 av, MonadBlobStore m) => BlobStorable m (PersistentAccountBaker av) where +instance + forall m store av. + (IsAccountVersion av, AVStructureV0 av, MonadBlobStore m, store ~ MBSStore m) => + BlobStorable m (PersistentAccountBaker store av) + where storeUpdate PersistentAccountBaker{..} = do (pBakerInfo, newBakerInfo) <- storeUpdate _accountBakerInfo (pExtraBakerInfo, newExtraBakerInfo) <- storeUpdate _extraBakerInfo @@ -296,14 +311,17 @@ instance forall m av. (IsAccountVersion av, AVStructureV0 av, MonadBlobStore m) _extraBakerInfo <- rExtraBakerInfo return PersistentAccountBaker{..} -instance (Applicative m) => Cacheable m (PersistentAccountBaker av) +instance (Applicative m) => Cacheable m (PersistentAccountBaker store av) -- | Getter for accessing the 'PersistentBakerInfoEx' of a 'PersistentAccountBaker'. -accountBakerInfoEx :: Getting r (PersistentAccountBaker av) (PersistentBakerInfoEx av) +accountBakerInfoEx :: Getting r (PersistentAccountBaker store av) (PersistentBakerInfoEx store av) accountBakerInfoEx = to (\PersistentAccountBaker{..} -> PersistentBakerInfoEx _accountBakerInfo _extraBakerInfo) -- | Lens for accessing the reference to the 'BakerPoolInfo' of a 'PersistentAccountBaker'. -bakerPoolInfoRef :: forall av. (IsAccountVersion av, AVStructureV0 av, AVSupportsDelegation av) => Lens' (PersistentAccountBaker av) (EagerBufferedRef BakerPoolInfo) +bakerPoolInfoRef :: + forall store av. + (IsAccountVersion av, AVStructureV0 av, AVSupportsDelegation av) => + Lens' (PersistentAccountBaker store av) (EagerBufferedRef store BakerPoolInfo) bakerPoolInfoRef = case accountVersion @av of SAccountV1 -> extraBakerInfo . theExtraBakerInfo @@ -311,7 +329,7 @@ bakerPoolInfoRef = case accountVersion @av of loadPersistentAccountBaker :: forall av m. (IsAccountVersion av, AVStructureV0 av, MonadBlobStore m) => - PersistentAccountBaker av -> + PersistentAccountBaker (MBSStore m) av -> m (AccountBaker av) loadPersistentAccountBaker PersistentAccountBaker{..} = do _accountBakerInfo <- @@ -324,7 +342,7 @@ makePersistentAccountBaker :: forall av m. (IsAccountVersion av, AVStructureV0 av, MonadBlobStore m) => AccountBaker av -> - m (PersistentAccountBaker av) + m (PersistentAccountBaker (MBSStore m) av) makePersistentAccountBaker AccountBaker{..} = do case accountVersion @av of SAccountV0 -> do @@ -351,8 +369,8 @@ migratePersistentAccountBaker :: SupportMigration m t ) => StateMigrationParameters oldpv pv -> - PersistentAccountBaker (AccountVersionFor oldpv) -> - t m (PersistentAccountBaker (AccountVersionFor pv)) + PersistentAccountBaker (MBSStore m) (AccountVersionFor oldpv) -> + t m (PersistentAccountBaker (MBSStore (t m)) (AccountVersionFor pv)) migratePersistentAccountBaker migration PersistentAccountBaker{..} = do newAccountBakerInfo <- migrateEagerBufferedRef return _accountBakerInfo newExtraBakerInfo <- migratePersistentExtraBakerInfo migration _extraBakerInfo @@ -371,29 +389,34 @@ migratePersistentAccountBaker migration PersistentAccountBaker{..} = do -- IMPORTANT NOTE: The 'Cacheable' instance relies on the fact that no recursive caching is -- necessary (due to the use of 'EagerBufferedRef's). If this changes, the instance for -- 'PersistentAccount' will also need to be updated. -data PersistentAccountStake (av :: AccountVersion) where - PersistentAccountStakeNone :: PersistentAccountStake av +data PersistentAccountStake store (av :: AccountVersion) where + PersistentAccountStakeNone :: PersistentAccountStake store av PersistentAccountStakeBaker :: - !(EagerBufferedRef (PersistentAccountBaker av)) -> - PersistentAccountStake av + !(EagerBufferedRef store (PersistentAccountBaker store av)) -> + PersistentAccountStake store av PersistentAccountStakeDelegate :: (AVSupportsDelegation av) => - !(EagerBufferedRef (AccountDelegation av)) -> - PersistentAccountStake av + !(EagerBufferedRef store (AccountDelegation av)) -> + PersistentAccountStake store av -deriving instance (IsAccountVersion av, AVStructureV0 av) => Show (PersistentAccountStake av) +deriving instance (IsAccountVersion av, AVStructureV0 av) => Show (PersistentAccountStake store av) -instance forall m av. (MonadBlobStore m, IsAccountVersion av, AVStructureV0 av) => BlobStorable m (PersistentAccountStake av) where +instance + forall m store av. + (MonadBlobStore m, IsAccountVersion av, AVStructureV0 av, store ~ MBSStore m) => + BlobStorable m (PersistentAccountStake store av) + where storeUpdate = case accountVersion @av of SAccountV0 -> su0 SAccountV1 -> su1 where - su0 :: PersistentAccountStake 'AccountV0 -> m (Put, PersistentAccountStake 'AccountV0) - su0 pas@PersistentAccountStakeNone = return (put (refNull :: BlobRef (PersistentAccountBaker av)), pas) + su0 :: PersistentAccountStake store 'AccountV0 -> m (Put, PersistentAccountStake store 'AccountV0) + su0 pas@PersistentAccountStakeNone = + return (put (refNull :: BlobRef store (PersistentAccountBaker store av)), pas) su0 (PersistentAccountStakeBaker bkrref) = do (r, bkrref') <- storeUpdate bkrref return (r, PersistentAccountStakeBaker bkrref') - su1 :: PersistentAccountStake av -> m (Put, PersistentAccountStake av) + su1 :: PersistentAccountStake store av -> m (Put, PersistentAccountStake store av) su1 pas@PersistentAccountStakeNone = return (putWord8 0, pas) su1 (PersistentAccountStakeBaker bkrref) = do (r, bkrref') <- storeUpdate bkrref @@ -405,12 +428,12 @@ instance forall m av. (MonadBlobStore m, IsAccountVersion av, AVStructureV0 av) SAccountV0 -> l0 SAccountV1 -> l1 where - l0 :: Get (m (PersistentAccountStake av)) + l0 :: Get (m (PersistentAccountStake store av)) l0 = do let toPASB Null = PersistentAccountStakeNone toPASB (Some br) = PersistentAccountStakeBaker br fmap toPASB <$> load - l1 :: (AVSupportsDelegation av) => Get (m (PersistentAccountStake av)) + l1 :: (AVSupportsDelegation av) => Get (m (PersistentAccountStake store av)) l1 = getWord8 >>= \case 0 -> return (pure PersistentAccountStakeNone) @@ -418,9 +441,12 @@ instance forall m av. (MonadBlobStore m, IsAccountVersion av, AVStructureV0 av) 2 -> fmap PersistentAccountStakeDelegate <$> load _ -> fail "Invalid staking type" -instance (Applicative m) => Cacheable m (PersistentAccountStake av) +instance (Applicative m) => Cacheable m (PersistentAccountStake store av) -instance (MonadBlobStore m, IsAccountVersion av, AVStructureV0 av) => MHashableTo m (AccountStakeHash av) (PersistentAccountStake av) where +instance + (MonadBlobStore m, store ~ MBSStore m, IsAccountVersion av, AVStructureV0 av) => + MHashableTo m (AccountStakeHash av) (PersistentAccountStake store av) + where getHashM PersistentAccountStakeNone = return $ getAccountStakeHash AccountStakeNone getHashM (PersistentAccountStakeBaker bkrref) = getAccountStakeHash . AccountStakeBaker <$> (loadPersistentAccountBaker =<< refLoad bkrref) @@ -428,7 +454,10 @@ instance (MonadBlobStore m, IsAccountVersion av, AVStructureV0 av) => MHashableT getAccountStakeHash . AccountStakeDelegate <$> refLoad dlgref -- | Load a 'PersistentAccountStake'. -loadAccountStake :: (MonadBlobStore m, IsAccountVersion av, AVStructureV0 av) => PersistentAccountStake av -> m (AccountStake av) +loadAccountStake :: + (MonadBlobStore m, IsAccountVersion av, AVStructureV0 av) => + PersistentAccountStake (MBSStore m) av -> + m (AccountStake av) loadAccountStake PersistentAccountStakeNone = return AccountStakeNone loadAccountStake (PersistentAccountStakeBaker bkr) = AccountStakeBaker <$> (loadPersistentAccountBaker =<< refLoad bkr) loadAccountStake (PersistentAccountStakeDelegate dlg) = AccountStakeDelegate <$> refLoad dlg @@ -443,8 +472,8 @@ migratePersistentAccountStake :: SupportMigration m t ) => StateMigrationParameters oldpv pv -> - PersistentAccountStake (AccountVersionFor oldpv) -> - t m (PersistentAccountStake (AccountVersionFor pv)) + PersistentAccountStake (MBSStore m) (AccountVersionFor oldpv) -> + t m (PersistentAccountStake (MBSStore (t m)) (AccountVersionFor pv)) migratePersistentAccountStake _ PersistentAccountStakeNone = return PersistentAccountStakeNone migratePersistentAccountStake migration (PersistentAccountStakeBaker r) = PersistentAccountStakeBaker <$!> migrateEagerBufferedRef (migratePersistentAccountBaker migration) r migratePersistentAccountStake StateMigrationParametersTrivial (PersistentAccountStakeDelegate r) = @@ -457,32 +486,35 @@ migratePersistentAccountStake StateMigrationParametersTrivial (PersistentAccount -- IMPORTANT NOTE: The 'Cacheable' instance relies on the fact that no recursive caching is -- necessary (due to the use of 'EagerBufferedRef's). This fact is also important to the -- implementation of 'load'. -data PersistentAccount (av :: AccountVersion) = PersistentAccount +data PersistentAccount store (av :: AccountVersion) = PersistentAccount { -- | Next available nonce for this account. _accountNonce :: !Nonce, -- | Current public account balance. _accountAmount :: !Amount, -- | List of encrypted amounts on the account. - _accountEncryptedAmount :: !(EagerBufferedRef PersistentAccountEncryptedAmount), + _accountEncryptedAmount :: !(EagerBufferedRef store (PersistentAccountEncryptedAmount store)), -- | Schedule of releases on the account. - _accountReleaseSchedule :: !(EagerBufferedRef AccountReleaseSchedule), + _accountReleaseSchedule :: !(EagerBufferedRef store (AccountReleaseSchedule store)), -- | A pointer to account data that changes rarely - _persistingData :: !(EagerlyHashedBufferedRef' PersistingAccountDataHash PersistingAccountData), + _persistingData :: !(EagerlyHashedBufferedRef' PersistingAccountDataHash store PersistingAccountData), -- | The baker info - _accountStake :: !(PersistentAccountStake av) + _accountStake :: !(PersistentAccountStake store av) } makeLenses ''PersistentAccount -accountBaker :: SimpleGetter (PersistentAccount av) (Nullable (EagerBufferedRef (PersistentAccountBaker av))) +accountBaker :: + SimpleGetter + (PersistentAccount store av) + (Nullable (EagerBufferedRef store (PersistentAccountBaker store av))) accountBaker = to g where g PersistentAccount{_accountStake = PersistentAccountStakeBaker bkr} = Some bkr g _ = Null -deriving instance (IsAccountVersion av, AVStructureV0 av) => Show (PersistentAccount av) +deriving instance (IsAccountVersion av, AVStructureV0 av) => Show (PersistentAccount store av) -instance (MonadBlobStore m, IsAccountVersion av, AVStructureV0 av) => BlobStorable m (PersistentAccount av) where +instance (MonadBlobStore m, store ~ MBSStore m, IsAccountVersion av, AVStructureV0 av) => BlobStorable m (PersistentAccount store av) where storeUpdate PersistentAccount{..} = do (pAccData :: Put, accData) <- storeUpdate _persistingData (pEnc, encData) <- storeUpdate _accountEncryptedAmount @@ -520,10 +552,13 @@ instance (MonadBlobStore m, IsAccountVersion av, AVStructureV0 av) => BlobStorab _accountStake <- mAccountStake return PersistentAccount{..} -instance (Applicative m) => Cacheable m (PersistentAccount av) +instance (Applicative m) => Cacheable m (PersistentAccount store av) -- | Generate the inputs for computing the account hash at V0. -hashInputsV0 :: (MonadBlobStore m, IsAccountVersion av, AVStructureV0 av) => PersistentAccount av -> m (AccountHashInputsV0 av) +hashInputsV0 :: + (MonadBlobStore m, IsAccountVersion av, AVStructureV0 av) => + PersistentAccount (MBSStore m) av -> + m (AccountHashInputsV0 av) hashInputsV0 PersistentAccount{..} = do eData <- refLoad _accountEncryptedAmount eData' <- loadPersistentAccountEncryptedAmount eData @@ -540,22 +575,22 @@ hashInputsV0 PersistentAccount{..} = do ahiAccountStakeHash = stakeHash } -instance (MonadBlobStore m) => MHashableTo m (AccountHash 'AccountV0) (PersistentAccount 'AccountV0) where +instance (MonadBlobStore m, store ~ MBSStore m) => MHashableTo m (AccountHash 'AccountV0) (PersistentAccount store 'AccountV0) where getHashM = fmap (makeAccountHash . AHIV0) . hashInputsV0 -instance (MonadBlobStore m) => MHashableTo m (AccountHash 'AccountV1) (PersistentAccount 'AccountV1) where +instance (MonadBlobStore m, store ~ MBSStore m) => MHashableTo m (AccountHash 'AccountV1) (PersistentAccount store 'AccountV1) where getHashM = fmap (makeAccountHash . AHIV1) . hashInputsV0 -instance (MonadBlobStore m) => MHashableTo m Hash.Hash (PersistentAccount 'AccountV0) where +instance (MonadBlobStore m, store ~ MBSStore m) => MHashableTo m Hash.Hash (PersistentAccount store 'AccountV0) where getHashM = fmap (theAccountHash @'AccountV0) . getHashM -instance (MonadBlobStore m) => MHashableTo m Hash.Hash (PersistentAccount 'AccountV1) where +instance (MonadBlobStore m, store ~ MBSStore m) => MHashableTo m Hash.Hash (PersistentAccount store 'AccountV1) where getHashM = fmap (theAccountHash @'AccountV1) . getHashM -- | Load a field from an account's 'PersistingAccountData' pointer. E.g., @acc ^^. accountAddress@ returns the account's address. (^^.) :: (MonadBlobStore m) => - PersistentAccount av -> + PersistentAccount (MBSStore m) av -> Getting b PersistingAccountData b -> m b acc ^^. l = (^. l) <$!> refLoad (acc ^. persistingData) @@ -569,8 +604,8 @@ setPAD :: forall m av. (MonadBlobStore m) => (PersistingAccountData -> PersistingAccountData) -> - PersistentAccount av -> - m (PersistentAccount av) + PersistentAccount (MBSStore m) av -> + m (PersistentAccount (MBSStore m) av) setPAD f acc = do pData <- refLoad (acc ^. persistingData) let newPData = f pData @@ -584,8 +619,8 @@ setPAD f acc = do (MonadBlobStore m) => ASetter PersistingAccountData PersistingAccountData a b -> b -> - PersistentAccount av -> - m (PersistentAccount av) + PersistentAccount (MBSStore m) av -> + m (PersistentAccount (MBSStore m) av) (.~~) l v = setPAD (l .~ v) {-# INLINE (.~~) #-} @@ -597,8 +632,8 @@ infixr 4 .~~ (MonadBlobStore m) => ASetter PersistingAccountData PersistingAccountData a b -> (a -> b) -> - PersistentAccount av -> - m (PersistentAccount av) + PersistentAccount (MBSStore m) av -> + m (PersistentAccount (MBSStore m) av) (%~~) l f = setPAD (l %~ f) {-# INLINE (%~~) #-} @@ -607,15 +642,15 @@ infixr 4 %~~ -- ** Queries -- | Get the canonical address of the account. -getCanonicalAddress :: (MonadBlobStore m) => PersistentAccount av -> m AccountAddress +getCanonicalAddress :: (MonadBlobStore m) => PersistentAccount (MBSStore m) av -> m AccountAddress getCanonicalAddress = (^^. accountAddress) -- | Get the current public account balance. -getAmount :: (Applicative m) => PersistentAccount av -> m Amount +getAmount :: (Applicative m) => PersistentAccount (MBSStore m) av -> m Amount getAmount = pure . view accountAmount -- | Get the amount that is staked on the account. -getStakedAmount :: (MonadBlobStore m, IsAccountVersion av, AVStructureV0 av) => PersistentAccount av -> m Amount +getStakedAmount :: (MonadBlobStore m, IsAccountVersion av, AVStructureV0 av) => PersistentAccount (MBSStore m) av -> m Amount getStakedAmount acc = getStakeDetails acc <&> \case StakeDetailsBaker{..} -> sdStakedCapital @@ -623,13 +658,13 @@ getStakedAmount acc = _ -> 0 -- | Get the amount that is locked in scheduled releases on the account. -getLockedAmount :: (MonadBlobStore m, IsAccountVersion av, AVStructureV0 av) => PersistentAccount av -> m Amount +getLockedAmount :: (MonadBlobStore m, IsAccountVersion av, AVStructureV0 av) => PersistentAccount (MBSStore m) av -> m Amount getLockedAmount acc = releaseScheduleLockedBalance <$!> refLoad (acc ^. accountReleaseSchedule) -- | Get the current public account available balance. -- This accounts for lock-up and staked amounts. -- @available = total - max locked staked@ -getAvailableAmount :: (MonadBlobStore m, IsAccountVersion av, AVStructureV0 av) => PersistentAccount av -> m Amount +getAvailableAmount :: (MonadBlobStore m, IsAccountVersion av, AVStructureV0 av) => PersistentAccount (MBSStore m) av -> m Amount getAvailableAmount acc = do total <- getAmount acc lockedUp <- getLockedAmount acc @@ -641,7 +676,7 @@ getAvailableAmount acc = do return $ total - max lockedUp staked -- | Get the next account nonce for transactions from this account. -getNonce :: (Applicative m) => PersistentAccount av -> m Nonce +getNonce :: (Applicative m) => PersistentAccount (MBSStore m) av -> m Nonce getNonce = pure . view accountNonce -- | Determine if a given operation is permitted for the account. @@ -649,7 +684,7 @@ getNonce = pure . view accountNonce -- * For 'AllowedEncryptedTransfers' the account may only have 1 credential. -- -- * For 'AllowedMultipleCredentials' the account must have the empty encrypted balance. -isAllowed :: (MonadBlobStore m) => PersistentAccount av -> AccountAllowance -> m Bool +isAllowed :: (MonadBlobStore m) => PersistentAccount (MBSStore m) av -> AccountAllowance -> m Bool isAllowed acc AllowedEncryptedTransfers = do creds <- getCredentials acc return $! Map.size creds == 1 @@ -658,19 +693,19 @@ isAllowed acc AllowedMultipleCredentials = -- | Get the credentials deployed on the account. This map is always non-empty and (presently) -- will have a credential at index 'initialCredentialIndex' (0) that cannot be changed. -getCredentials :: (MonadBlobStore m) => PersistentAccount av -> m (Map.Map CredentialIndex RawAccountCredential) +getCredentials :: (MonadBlobStore m) => PersistentAccount (MBSStore m) av -> m (Map.Map CredentialIndex RawAccountCredential) getCredentials = (^^. accountCredentials) -- | Get the key used to verify transaction signatures, it records the signature scheme used as well. -getVerificationKeys :: (MonadBlobStore m) => PersistentAccount av -> m AccountInformation +getVerificationKeys :: (MonadBlobStore m) => PersistentAccount (MBSStore m) av -> m AccountInformation getVerificationKeys = (^^. accountVerificationKeys) -- | Get the current encrypted amount on the account. -getEncryptedAmount :: (MonadBlobStore m) => PersistentAccount av -> m AccountEncryptedAmount +getEncryptedAmount :: (MonadBlobStore m) => PersistentAccount (MBSStore m) av -> m AccountEncryptedAmount getEncryptedAmount acc = loadPersistentAccountEncryptedAmount =<< refLoad (acc ^. accountEncryptedAmount) -- | Get the public key used to receive encrypted amounts. -getEncryptionKey :: (MonadBlobStore f) => PersistentAccount av -> f AccountEncryptionKey +getEncryptionKey :: (MonadBlobStore f) => PersistentAccount (MBSStore f) av -> f AccountEncryptionKey -- The use of the unsafe @unsafeEncryptionKeyFromRaw@ function here is -- justified because the encryption key was validated when it was -- created/deployed (this is part of credential validation) @@ -679,7 +714,7 @@ getEncryptionKey acc = ID.unsafeEncryptionKeyFromRaw <$> acc ^^. accountEncrypti -- | Get the release schedule for an account. getReleaseSummary :: (MonadBlobStore m, IsAccountVersion av, AVStructureV0 av) => - PersistentAccount av -> + PersistentAccount (MBSStore m) av -> m AccountReleaseSummary getReleaseSummary acc = do prs <- refLoad (acc ^. accountReleaseSchedule) @@ -687,11 +722,15 @@ getReleaseSummary acc = do return $ ARSV0.toAccountReleaseSummary ars -- | Get the timestamp at which the next scheduled release will occur (if any). -getNextReleaseTimestamp :: (MonadBlobStore m) => PersistentAccount av -> m (Maybe Timestamp) +getNextReleaseTimestamp :: (MonadBlobStore m) => PersistentAccount (MBSStore m) av -> m (Maybe Timestamp) getNextReleaseTimestamp acc = nextReleaseTimestamp <$!> refLoad (acc ^. accountReleaseSchedule) -- | Get the baker and baker info reference (if any) attached to the account. -getBakerAndInfoRef :: forall m av. (MonadBlobStore m, IsAccountVersion av, AVStructureV0 av) => PersistentAccount av -> m (Maybe (AccountBaker av, PersistentBakerInfoEx av)) +getBakerAndInfoRef :: + forall m av. + (MonadBlobStore m, IsAccountVersion av, AVStructureV0 av) => + PersistentAccount (MBSStore m) av -> + m (Maybe (AccountBaker av, PersistentBakerInfoEx (MBSStore m) av)) getBakerAndInfoRef acc = case acc ^. accountBaker of Null -> return Nothing Some bref -> do @@ -719,14 +758,14 @@ getBakerAndInfoRef acc = case acc ^. accountBaker of ) -- | Get the baker (if any) attached to an account. -getBaker :: forall m av. (MonadBlobStore m, IsAccountVersion av, AVStructureV0 av) => PersistentAccount av -> m (Maybe (AccountBaker av)) +getBaker :: forall m av. (MonadBlobStore m, IsAccountVersion av, AVStructureV0 av) => PersistentAccount (MBSStore m) av -> m (Maybe (AccountBaker av)) getBaker acc = fmap fst <$> getBakerAndInfoRef acc -- | Get the baker and baker info reference (if any) attached to the account. getBakerInfoRef :: (MonadBlobStore m, IsAccountVersion av, AVStructureV0 av) => - PersistentAccount av -> - m (Maybe (PersistentBakerInfoEx av)) + PersistentAccount (MBSStore m) av -> + m (Maybe (PersistentBakerInfoEx (MBSStore m) av)) getBakerInfoRef acc = case acc ^. accountBaker of Null -> return Nothing Some bref -> do @@ -734,22 +773,22 @@ getBakerInfoRef acc = case acc ^. accountBaker of return (Just (pab ^. accountBakerInfoEx)) -- | Get the delegator (if any) attached to the account. -getDelegator :: (MonadBlobStore m, IsAccountVersion av) => PersistentAccount av -> m (Maybe (AccountDelegation av)) +getDelegator :: (MonadBlobStore m, IsAccountVersion av) => PersistentAccount (MBSStore m) av -> m (Maybe (AccountDelegation av)) getDelegator PersistentAccount{_accountStake = PersistentAccountStakeDelegate del} = Just <$> refLoad del getDelegator _ = return Nothing -- | Get the baker or stake delegation information attached to an account. -getStake :: (MonadBlobStore m, IsAccountVersion av, AVStructureV0 av) => PersistentAccount av -> m (AccountStake av) +getStake :: (MonadBlobStore m, IsAccountVersion av, AVStructureV0 av) => PersistentAccount (MBSStore m) av -> m (AccountStake av) getStake acc = loadAccountStake (acc ^. accountStake) -- | Determine if an account has stake as a baker or delegator. -hasActiveStake :: PersistentAccount av -> Bool +hasActiveStake :: PersistentAccount store av -> Bool hasActiveStake acc = case acc ^. accountStake of PersistentAccountStakeNone -> False _ -> True -- | Get details about an account's stake. -getStakeDetails :: (MonadBlobStore m, IsAccountVersion av, AVStructureV0 av) => PersistentAccount av -> m (StakeDetails av) +getStakeDetails :: (MonadBlobStore m, IsAccountVersion av, AVStructureV0 av) => PersistentAccount (MBSStore m) av -> m (StakeDetails av) getStakeDetails acc = case acc ^. accountStake of PersistentAccountStakeNone -> return StakeDetailsNone PersistentAccountStakeBaker bkrRef -> do @@ -771,7 +810,7 @@ getStakeDetails acc = case acc ^. accountStake of } -- | Gets the amount of a baker's stake, or 'Nothing' if the account is not a baker. -getBakerStakeAmount :: (MonadBlobStore m, IsAccountVersion av, AVStructureV0 av) => PersistentAccount av -> m (Maybe Amount) +getBakerStakeAmount :: (MonadBlobStore m, IsAccountVersion av, AVStructureV0 av) => PersistentAccount (MBSStore m) av -> m (Maybe Amount) getBakerStakeAmount acc = case acc ^. accountBaker of Null -> return Nothing Some bref -> do @@ -780,7 +819,7 @@ getBakerStakeAmount acc = case acc ^. accountBaker of -- | Apply account updates to an account. It is assumed that the address in -- account updates and account are the same. -updateAccount :: forall m av. (MonadBlobStore m, AVStructureV0 av) => AccountUpdate -> PersistentAccount av -> m (PersistentAccount av) +updateAccount :: forall m av. (MonadBlobStore m, AVStructureV0 av) => AccountUpdate -> PersistentAccount (MBSStore m) av -> m (PersistentAccount (MBSStore m) av) updateAccount !upd !acc = do releaseScheduleUpdate <- case upd ^. auReleaseSchedule of Just l -> do @@ -832,8 +871,8 @@ updateAccountCredentials :: -- | New account threshold AccountThreshold -> -- | Account to update - PersistentAccount av -> - m (PersistentAccount av) + PersistentAccount (MBSStore m) av -> + m (PersistentAccount (MBSStore m) av) updateAccountCredentials cuRemove cuAdd cuAccountThreshold = setPAD (updateCredentials cuRemove cuAdd cuAccountThreshold) @@ -846,15 +885,15 @@ updateAccountCredentialKeys :: -- | New public keys CredentialPublicKeys -> -- | Account to update - PersistentAccount av -> - m (PersistentAccount av) + PersistentAccount (MBSStore m) av -> + m (PersistentAccount (MBSStore m) av) updateAccountCredentialKeys credIndex credKeys = setPAD (updateCredentialKeys credIndex credKeys) -- | Add an amount to the account's balance. -addAmount :: (MonadBlobStore m) => Amount -> PersistentAccount av -> m (PersistentAccount av) +addAmount :: (MonadBlobStore m) => Amount -> PersistentAccount (MBSStore m) av -> m (PersistentAccount (MBSStore m) av) addAmount !amt acc = return $! acc & accountAmount +~ amt -applyPendingStakeChange :: (MonadBlobStore m, IsAccountVersion av, AVStructureV0 av) => PersistentAccount av -> m (PersistentAccount av) +applyPendingStakeChange :: (MonadBlobStore m, IsAccountVersion av, AVStructureV0 av) => PersistentAccount (MBSStore m) av -> m (PersistentAccount (MBSStore m) av) applyPendingStakeChange acc = case acc ^. accountStake of PersistentAccountStakeNone -> noPendingChange PersistentAccountStakeBaker ebr -> do @@ -882,8 +921,8 @@ addBakerV0 :: (MonadBlobStore m) => BakerId -> BakerAdd -> - PersistentAccount 'AccountV0 -> - m (PersistentAccount 'AccountV0) + PersistentAccount (MBSStore m) 'AccountV0 -> + m (PersistentAccount (MBSStore m) 'AccountV0) addBakerV0 bid BakerAdd{..} acc = do newBakerInfo <- refMake $ @@ -910,8 +949,8 @@ addBakerV1 :: -- | Whether earnings are restaked Bool -> -- | Account to add baker to - PersistentAccount av -> - m (PersistentAccount av) + PersistentAccount (MBSStore m) av -> + m (PersistentAccount (MBSStore m) av) addBakerV1 BakerInfoExV1{..} stake restake acc = do poolInfoRef <- refMake _bieBakerPoolInfo bakerInfoRef <- refMake _bieBakerInfo @@ -931,8 +970,8 @@ addBakerV1 BakerInfoExV1{..} stake restake acc = do addDelegator :: (MonadBlobStore m, IsAccountVersion av, AVSupportsDelegation av) => AccountDelegation av -> - PersistentAccount av -> - m (PersistentAccount av) + PersistentAccount (MBSStore m) av -> + m (PersistentAccount (MBSStore m) av) addDelegator del acc = do delegatorRef <- refMake del return $! acc{_accountStake = PersistentAccountStakeDelegate delegatorRef} @@ -942,8 +981,8 @@ addDelegator del acc = do updateBakerPoolInfo :: (MonadBlobStore m, IsAccountVersion av, AVStructureV0 av, AVSupportsDelegation av) => BakerPoolInfoUpdate -> - PersistentAccount av -> - m (PersistentAccount av) + PersistentAccount (MBSStore m) av -> + m (PersistentAccount (MBSStore m) av) updateBakerPoolInfo upd acc@PersistentAccount{_accountStake = PersistentAccountStakeBaker oldBakerRef} | upd == emptyBakerPoolInfoUpdate = return acc | otherwise = do @@ -959,8 +998,8 @@ updateBakerPoolInfo _ _ = error "updateBakerPoolInfo invariant violation: accoun setBakerKeys :: (MonadBlobStore m, IsAccountVersion av, AVStructureV0 av) => BakerKeyUpdate -> - PersistentAccount av -> - m (PersistentAccount av) + PersistentAccount (MBSStore m) av -> + m (PersistentAccount (MBSStore m) av) setBakerKeys upd acc@PersistentAccount{_accountStake = PersistentAccountStakeBaker oldBakerRef} = do oldBaker <- refLoad oldBakerRef oldBakerInfo <- refLoad (oldBaker ^. accountBakerInfo) @@ -982,8 +1021,8 @@ setBakerKeys _ _ = error "setBakerKeys invariant violation: account is not a bak setStake :: (MonadBlobStore m, IsAccountVersion av, AVStructureV0 av) => Amount -> - PersistentAccount av -> - m (PersistentAccount av) + PersistentAccount (MBSStore m) av -> + m (PersistentAccount (MBSStore m) av) setStake newAmount acc@PersistentAccount{_accountStake = PersistentAccountStakeBaker oldBakerRef} = do oldBaker <- refLoad oldBakerRef newBakerRef <- refMake $! oldBaker & stakedAmount .~ newAmount @@ -999,8 +1038,8 @@ setStake _ _ = error "setStake invariant violation: account is not a baker or de setRestakeEarnings :: (MonadBlobStore m, IsAccountVersion av, AVStructureV0 av) => Bool -> - PersistentAccount av -> - m (PersistentAccount av) + PersistentAccount (MBSStore m) av -> + m (PersistentAccount (MBSStore m) av) setRestakeEarnings restake acc@PersistentAccount{_accountStake = PersistentAccountStakeBaker oldBakerRef} = do oldBaker <- refLoad oldBakerRef newBakerRef <- refMake $! oldBaker & stakeEarnings .~ restake @@ -1016,8 +1055,8 @@ setRestakeEarnings _ _ = error "setRestakeEarnings invariant violation: account setStakePendingChange :: (MonadBlobStore m, IsAccountVersion av, AVStructureV0 av) => StakePendingChange av -> - PersistentAccount av -> - m (PersistentAccount av) + PersistentAccount (MBSStore m) av -> + m (PersistentAccount (MBSStore m) av) setStakePendingChange newPC acc@PersistentAccount{_accountStake = PersistentAccountStakeBaker oldBakerRef} = do oldBaker <- refLoad oldBakerRef newBakerRef <- refMake $! oldBaker & bakerPendingChange .~ newPC @@ -1033,8 +1072,8 @@ setStakePendingChange _ _ = error "setStakePendingChange invariant violation: ac setDelegationTarget :: (MonadBlobStore m, IsAccountVersion av) => DelegationTarget -> - PersistentAccount av -> - m (PersistentAccount av) + PersistentAccount (MBSStore m) av -> + m (PersistentAccount (MBSStore m) av) setDelegationTarget target acc@PersistentAccount{_accountStake = PersistentAccountStakeDelegate oldDelRef} = do oldDel <- refLoad oldDelRef newDelRef <- refMake $ oldDel & delegationTarget .~ target @@ -1044,8 +1083,8 @@ setDelegationTarget _ _ = error "setDelegationTarget invariant violation: accoun -- | Remove any staking on an account. removeStaking :: (MonadBlobStore m, IsAccountVersion av) => - PersistentAccount av -> - m (PersistentAccount av) + PersistentAccount (MBSStore m) av -> + m (PersistentAccount (MBSStore m) av) removeStaking acc = return $! acc{_accountStake = PersistentAccountStakeNone} -- | Set the commission rates on a baker account. @@ -1053,8 +1092,8 @@ removeStaking acc = return $! acc{_accountStake = PersistentAccountStakeNone} setCommissionRates :: (MonadBlobStore m, IsAccountVersion av, AVStructureV0 av, AVSupportsDelegation av) => CommissionRates -> - PersistentAccount av -> - m (PersistentAccount av) + PersistentAccount (MBSStore m) av -> + m (PersistentAccount (MBSStore m) av) setCommissionRates rates acc@PersistentAccount{_accountStake = PersistentAccountStakeBaker oldBakerRef} = do oldBaker <- refLoad oldBakerRef oldPoolInfo <- refLoad (oldBaker ^. bakerPoolInfoRef) @@ -1066,7 +1105,7 @@ setCommissionRates _ _ = error "setCommissionRates invariant violation: account -- | Unlock scheduled releases on an account up to and including the given timestamp. -- This returns the next timestamp at which a release is scheduled for the account, if any, -- as well as the updated account. -unlockReleases :: (MonadBlobStore m) => Timestamp -> PersistentAccount av -> m (Maybe Timestamp, PersistentAccount av) +unlockReleases :: (MonadBlobStore m) => Timestamp -> PersistentAccount (MBSStore m) av -> m (Maybe Timestamp, PersistentAccount (MBSStore m) av) unlockReleases ts acc = do rData <- refLoad (acc ^. accountReleaseSchedule) (_, nextTs, rData') <- unlockAmountsUntil ts rData @@ -1083,7 +1122,7 @@ newAccount :: GlobalContext -> AccountAddress -> AccountCredential -> - m (PersistentAccount av) + m (PersistentAccount (MBSStore m) av) newAccount cryptoParams _accountAddress credential = do let creds = Map.singleton initialCredentialIndex credential let newPData = @@ -1098,7 +1137,7 @@ newAccount cryptoParams _accountAddress credential = do _persistingData <- refMake newPData let _accountNonce = minNonce _accountAmount = 0 - _accountStake = PersistentAccountStakeNone @av + _accountStake = PersistentAccountStakeNone @_ @av accountEncryptedAmountData <- initialPersistentAccountEncryptedAmount _accountEncryptedAmount <- refMake accountEncryptedAmountData let relSched = emptyAccountReleaseSchedule @@ -1114,7 +1153,7 @@ makeFromGenesisAccount :: GlobalContext -> ChainParameters pv -> GenesisAccount -> - m (PersistentAccount av) + m (PersistentAccount (MBSStore m) av) makeFromGenesisAccount spv cryptoParams chainParameters GenesisAccount{..} = do _persistingData <- refMakeFlushed $ @@ -1132,19 +1171,19 @@ makeFromGenesisAccount spv cryptoParams chainParameters GenesisAccount{..} = do let _accountNonce = minNonce _accountAmount = gaBalance _accountStake <- case gaBaker of - Nothing -> return $ PersistentAccountStakeNone @av + Nothing -> return $ PersistentAccountStakeNone @_ @av Just baker -> do let accountBaker' :: AccountBaker av = genesisBakerInfo spv chainParameters baker persistentAccountBaker' <- makePersistentAccountBaker accountBaker' accountBakerRef <- refMakeFlushed persistentAccountBaker' - return $ PersistentAccountStakeBaker @av accountBakerRef + return $ PersistentAccountStakeBaker @_ @av accountBakerRef accountEncryptedAmountData <- initialPersistentAccountEncryptedAmount _accountEncryptedAmount <- refMakeFlushed accountEncryptedAmountData _accountReleaseSchedule <- refMakeFlushed emptyAccountReleaseSchedule return PersistentAccount{..} -- | Make a 'PersistentAccount' from an 'Transient.Account'. -makePersistentAccount :: (MonadBlobStore m, IsAccountVersion av, AVStructureV0 av) => Transient.Account av -> m (PersistentAccount av) +makePersistentAccount :: (MonadBlobStore m, IsAccountVersion av, AVStructureV0 av) => Transient.Account av -> m (PersistentAccount (MBSStore m) av) makePersistentAccount tacc@Transient.Account{..} = do _persistingData <- refMake (tacc ^. persistingAccountData) _accountEncryptedAmount' <- refMake =<< storePersistentAccountEncryptedAmount _accountEncryptedAmount @@ -1159,7 +1198,7 @@ makePersistentAccount tacc@Transient.Account{..} = do makePersistentAccountRef :: (MonadBlobStore m, IsAccountVersion av, AVStructureV0 av) => Hashed' (AccountHash av) (Transient.Account av) -> - m (HashedCachedRef c (PersistentAccount av)) + m (HashedCachedRef (MBSStore m) c (PersistentAccount (MBSStore m) av)) makePersistentAccountRef (Hashed tacc acctHash) = do pacc <- makePersistentAccount tacc makeHashedCachedRef pacc (theAccountHash acctHash) @@ -1176,8 +1215,8 @@ migratePersistentAccount :: SupportMigration m t ) => StateMigrationParameters oldpv pv -> - PersistentAccount (AccountVersionFor oldpv) -> - t m (PersistentAccount (AccountVersionFor pv)) + PersistentAccount (MBSStore m) (AccountVersionFor oldpv) -> + t m (PersistentAccount (MBSStore (t m)) (AccountVersionFor pv)) migratePersistentAccount migration PersistentAccount{..} = do !newAccountEncryptedAmount <- migrateEagerBufferedRef migratePersistentEncryptedAmount _accountEncryptedAmount !newAccountReleaseSchedule <- migrateEagerBufferedRef migratePersistentAccountReleaseSchedule _accountReleaseSchedule @@ -1196,7 +1235,11 @@ migratePersistentAccount migration PersistentAccount{..} = do -- ** Conversion -- | Converts an account to a transient (i.e. in memory) account. (Used for testing.) -toTransientAccount :: forall m av. (MonadBlobStore m, IsAccountVersion av, AVStructureV0 av) => PersistentAccount av -> m (Transient.Account av) +toTransientAccount :: + forall m av. + (MonadBlobStore m, IsAccountVersion av, AVStructureV0 av) => + PersistentAccount (MBSStore m) av -> + m (Transient.Account av) toTransientAccount PersistentAccount{..} = do _accountPersisting <- Transient.makeAccountPersisting <$> refLoad _persistingData _accountEncryptedAmount <- loadPersistentAccountEncryptedAmount =<< refLoad _accountEncryptedAmount diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Account/StructureV1.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Account/StructureV1.hs index f1777b8e16..d3bb045dca 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Account/StructureV1.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Account/StructureV1.hs @@ -77,29 +77,29 @@ import Concordium.ID.Parameters -- and the current/next epoch bakers. We use a 'LazyBufferedRef' so that the reference does not -- need to be loaded whenever the account is loaded, but once it is loaded, copies of the reference -- (e.g. in the account cache) will also be loaded. -type PersistentBakerInfoEx av = LazyBufferedRef (BakerInfoEx av) +type PersistentBakerInfoEx store av = LazyBufferedRef store (BakerInfoEx av) -- ** Query -- | Load 'BakerInfo' from a 'PersistentBakerInfoEx'. -loadBakerInfo :: (MonadBlobStore m, IsAccountVersion av) => PersistentBakerInfoEx av -> m BakerInfo +loadBakerInfo :: (MonadBlobStore m, IsAccountVersion av) => PersistentBakerInfoEx (MBSStore m) av -> m BakerInfo loadBakerInfo = fmap _bieBakerInfo . refLoad -- | Load a 'BakerInfoEx' from a 'PersistentBakerInfoEx'. loadPersistentBakerInfoEx :: (MonadBlobStore m, IsAccountVersion av) => - PersistentBakerInfoEx av -> + PersistentBakerInfoEx (MBSStore m) av -> m (BakerInfoEx av) loadPersistentBakerInfoEx = refLoad -- | Load the 'BakerId' from a 'PersistentBakerInfoEx'. -loadBakerId :: (MonadBlobStore m, IsAccountVersion av) => PersistentBakerInfoEx av -> m BakerId +loadBakerId :: (MonadBlobStore m, IsAccountVersion av) => PersistentBakerInfoEx (MBSStore m) av -> m BakerId loadBakerId = fmap (view bakerIdentity) . refLoad -- ** Construction -- | Construct a 'PersistentBakerInfoEx' from a 'BakerInfoEx'. -makePersistentBakerInfoEx :: (MonadBlobStore m, IsAccountVersion av) => BakerInfoEx av -> m (PersistentBakerInfoEx av) +makePersistentBakerInfoEx :: (MonadBlobStore m, IsAccountVersion av) => BakerInfoEx av -> m (PersistentBakerInfoEx (MBSStore m) av) makePersistentBakerInfoEx = refMake -- ** Migration @@ -111,8 +111,8 @@ migratePersistentBakerInfoEx :: SupportMigration m t ) => StateMigrationParameters oldpv pv -> - PersistentBakerInfoEx (AccountVersionFor oldpv) -> - t m (PersistentBakerInfoEx (AccountVersionFor pv)) + PersistentBakerInfoEx (MBSStore m) (AccountVersionFor oldpv) -> + t m (PersistentBakerInfoEx (MBSStore (t m)) (AccountVersionFor pv)) migratePersistentBakerInfoEx StateMigrationParametersTrivial = migrateReference return migratePersistentBakerInfoEx StateMigrationParametersP5ToP6{} = migrateReference return migratePersistentBakerInfoEx StateMigrationParametersP6ToP7{} = migrateReference migrateBakerInfoExV1 @@ -131,8 +131,8 @@ migratePersistentBakerInfoExFromV0 :: SupportMigration m t ) => StateMigrationParameters oldpv pv -> - V0.PersistentBakerInfoEx (AccountVersionFor oldpv) -> - t m (PersistentBakerInfoEx (AccountVersionFor pv)) + V0.PersistentBakerInfoEx (MBSStore m) (AccountVersionFor oldpv) -> + t m (PersistentBakerInfoEx (MBSStore (t m)) (AccountVersionFor pv)) migratePersistentBakerInfoExFromV0 StateMigrationParametersP4ToP5{} V0.PersistentBakerInfoEx{..} = do bkrInfoEx <- lift $ do bkrInfo <- refLoad bakerInfoRef @@ -149,27 +149,27 @@ migratePersistentBakerInfoExFromV0 StateMigrationParametersP4ToP5{} V0.Persisten -- -- Note, only the baker info is stored under a reference. The reference is a 'LazyBufferedRef' -- rather than an 'EagerBufferedRef', as it will often be unnecessary to load the baker info. -data PersistentAccountStakeEnduring av where - PersistentAccountStakeEnduringNone :: PersistentAccountStakeEnduring av +data PersistentAccountStakeEnduring store av where + PersistentAccountStakeEnduringNone :: PersistentAccountStakeEnduring store av PersistentAccountStakeEnduringBaker :: { paseBakerRestakeEarnings :: !Bool, - paseBakerInfo :: !(LazyBufferedRef (BakerInfoEx av)), + paseBakerInfo :: !(LazyBufferedRef store (BakerInfoEx av)), paseBakerPendingChange :: !(StakePendingChange av) } -> - PersistentAccountStakeEnduring av + PersistentAccountStakeEnduring store av PersistentAccountStakeEnduringDelegator :: { paseDelegatorId :: !DelegatorId, paseDelegatorRestakeEarnings :: !Bool, paseDelegatorTarget :: !DelegationTarget, paseDelegatorPendingChange :: !(StakePendingChange av) } -> - PersistentAccountStakeEnduring av + PersistentAccountStakeEnduring store av -- | Convert a 'PersistentAccountStakeEnduring' to an 'AccountStake' given the amount of the stake. -- This is used to implement 'getStake', and is also used in computing the stake hash. persistentToAccountStake :: (MonadBlobStore m, IsAccountVersion av, AVSupportsDelegation av) => - PersistentAccountStakeEnduring av -> + PersistentAccountStakeEnduring (MBSStore m) av -> Amount -> m (AccountStake av) persistentToAccountStake PersistentAccountStakeEnduringNone _ = return AccountStakeNone @@ -197,8 +197,8 @@ persistentToAccountStake PersistentAccountStakeEnduringDelegator{..} _delegation -- version is unchanged. migratePersistentAccountStakeEnduring :: (SupportMigration m t, IsAccountVersion av) => - PersistentAccountStakeEnduring av -> - t m (PersistentAccountStakeEnduring av) + PersistentAccountStakeEnduring (MBSStore m) av -> + t m (PersistentAccountStakeEnduring (MBSStore (t m)) av) migratePersistentAccountStakeEnduring PersistentAccountStakeEnduringNone = return PersistentAccountStakeEnduringNone migratePersistentAccountStakeEnduring PersistentAccountStakeEnduringBaker{..} = do @@ -231,6 +231,7 @@ runStakedBalanceStateTT = State.runStateT . runStakedBalanceStateTT' instance (MonadTrans t) => MonadTrans (StakedBalanceStateTT t) where lift = StakedBalanceStateTT . lift . lift +type instance MBSStore (StakedBalanceStateTT t m) = MBSStore (t m) deriving via forall (t :: (Type -> Type) -> (Type -> Type)) (m :: Type -> Type). State.StateT Amount (t m) @@ -262,9 +263,9 @@ liftStakedBalanceStateTT = StakedBalanceStateTT . lift -- delegator's (updated) stake and target. migratePersistentAccountStakeEnduringV2toV3 :: (SupportMigration m t, AccountMigration 'AccountV3 (t m)) => - PersistentAccountStakeEnduring 'AccountV2 -> + PersistentAccountStakeEnduring (MBSStore m) 'AccountV2 -> -- | Returns the new 'PersistentAccountStakeEnduring' and 'CooldownQueue'. - StakedBalanceStateTT t m (PersistentAccountStakeEnduring 'AccountV3, CooldownQueue 'AccountV3) + StakedBalanceStateTT t m (PersistentAccountStakeEnduring (MBSStore (t m)) 'AccountV3, CooldownQueue (MBSStore (t m)) 'AccountV3) migratePersistentAccountStakeEnduringV2toV3 PersistentAccountStakeEnduringNone = return (PersistentAccountStakeEnduringNone, emptyCooldownQueue) migratePersistentAccountStakeEnduringV2toV3 PersistentAccountStakeEnduringBaker{..} = @@ -344,10 +345,16 @@ migratePersistentAccountStakeEnduringV2toV3 PersistentAccountStakeEnduringDelega -- | This relies on the fact that the 'AccountV2' hashing of 'AccountStake' is independent of the -- staked amount. -instance (MonadBlobStore m) => MHashableTo m (AccountStakeHash 'AccountV2) (PersistentAccountStakeEnduring 'AccountV2) where +instance + (MonadBlobStore m, store ~ MBSStore m) => + MHashableTo m (AccountStakeHash 'AccountV2) (PersistentAccountStakeEnduring store 'AccountV2) + where getHashM stake = getHash <$> persistentToAccountStake stake 0 -instance (MonadBlobStore m) => MHashableTo m (AccountStakeHash 'AccountV3) (PersistentAccountStakeEnduring 'AccountV3) where +instance + (MonadBlobStore m, store ~ MBSStore m) => + MHashableTo m (AccountStakeHash 'AccountV3) (PersistentAccountStakeEnduring store 'AccountV3) + where getHashM stake = getHash <$> persistentToAccountStake stake 0 -- * Enduring account data @@ -372,30 +379,30 @@ instance (MonadBlobStore m) => MHashableTo m (AccountStakeHash 'AccountV3) (Pers -- -- The stake is not stored under a reference (excepting the baker info, as per the definition of -- 'PersistentAccountStakeEnduring'). This is since the information is relatively succinct. -data PersistentAccountEnduringData (av :: AccountVersion) = PersistentAccountEnduringData +data PersistentAccountEnduringData store (av :: AccountVersion) = PersistentAccountEnduringData { -- | The Merkle hash computed from the other fields. paedHash :: !(AccountMerkleHash av), -- | A reference to the persisting account data. - paedPersistingData :: !(EagerBufferedRef PersistingAccountData), + paedPersistingData :: !(EagerBufferedRef store PersistingAccountData), -- | The encrypted amount. Invariant: if this is present, it will not satisfy -- 'isInitialPersistentAccountEncryptedAmount'. - paedEncryptedAmount :: !(Nullable (LazyBufferedRef PersistentAccountEncryptedAmount)), + paedEncryptedAmount :: !(Nullable (LazyBufferedRef store (PersistentAccountEncryptedAmount store))), -- | The release schedule and total locked amount. Invariant: if this is present, -- it does not satisfy 'isEmptyAccountReleaseSchedule', and the amount will be the total of them. - paedReleaseSchedule :: !(Nullable (LazyBufferedRef AccountReleaseSchedule, Amount)), + paedReleaseSchedule :: !(Nullable (LazyBufferedRef store (AccountReleaseSchedule store), Amount)), -- | The staking details associated with the account. - paedStake :: !(PersistentAccountStakeEnduring av), + paedStake :: !(PersistentAccountStakeEnduring store av), -- | The inactive stake in cooldown. - paedStakeCooldown :: !(CooldownQueue av) + paedStakeCooldown :: !(CooldownQueue store av) } -- | Get the locked amount from a 'PersistingAccountEnduringData'. -paedLockedAmount :: PersistentAccountEnduringData av -> Amount +paedLockedAmount :: PersistentAccountEnduringData store av -> Amount paedLockedAmount PersistentAccountEnduringData{..} = case paedReleaseSchedule of Some (_, amt) -> amt Null -> 0 -instance HashableTo (AccountMerkleHash av) (PersistentAccountEnduringData av) where +instance HashableTo (AccountMerkleHash av) (PersistentAccountEnduringData store av) where getHash = paedHash -- | Construct a 'PersistentAccountEnduringData' from the components by computing the hash. @@ -409,11 +416,11 @@ instance HashableTo (AccountMerkleHash av) (PersistentAccountEnduringData av) wh makeAccountEnduringDataAV2 :: ( MonadBlobStore m ) => - EagerBufferedRef PersistingAccountData -> - Nullable (LazyBufferedRef PersistentAccountEncryptedAmount) -> - Nullable (LazyBufferedRef AccountReleaseSchedule, Amount) -> - PersistentAccountStakeEnduring 'AccountV2 -> - m (PersistentAccountEnduringData 'AccountV2) + EagerBufferedRef (MBSStore m) PersistingAccountData -> + Nullable (LazyBufferedRef (MBSStore m) (PersistentAccountEncryptedAmount (MBSStore m))) -> + Nullable (LazyBufferedRef (MBSStore m) (AccountReleaseSchedule (MBSStore m)), Amount) -> + PersistentAccountStakeEnduring (MBSStore m) 'AccountV2 -> + m (PersistentAccountEnduringData (MBSStore m) 'AccountV2) makeAccountEnduringDataAV2 paedPersistingData paedEncryptedAmount paedReleaseSchedule paedStake = do amhi2PersistingAccountDataHash <- getHashM paedPersistingData (amhi2AccountStakeHash :: AccountStakeHash 'AccountV2) <- getHashM paedStake @@ -440,12 +447,12 @@ makeAccountEnduringDataAV2 paedPersistingData paedEncryptedAmount paedReleaseSch makeAccountEnduringDataAV3 :: ( MonadBlobStore m ) => - EagerBufferedRef PersistingAccountData -> - Nullable (LazyBufferedRef PersistentAccountEncryptedAmount) -> - Nullable (LazyBufferedRef AccountReleaseSchedule, Amount) -> - PersistentAccountStakeEnduring 'AccountV3 -> - CooldownQueue 'AccountV3 -> - m (PersistentAccountEnduringData 'AccountV3) + EagerBufferedRef (MBSStore m) PersistingAccountData -> + Nullable (LazyBufferedRef (MBSStore m) (PersistentAccountEncryptedAmount (MBSStore m))) -> + Nullable (LazyBufferedRef (MBSStore m) (AccountReleaseSchedule (MBSStore m)), Amount) -> + PersistentAccountStakeEnduring (MBSStore m) 'AccountV3 -> + CooldownQueue (MBSStore m) 'AccountV3 -> + m (PersistentAccountEnduringData (MBSStore m) 'AccountV3) makeAccountEnduringDataAV3 paedPersistingData paedEncryptedAmount paedReleaseSchedule paedStake paedStakeCooldown = do amhi3PersistingAccountDataHash <- getHashM paedPersistingData (amhi3AccountStakeHash :: AccountStakeHash 'AccountV3) <- getHashM paedStake @@ -465,8 +472,8 @@ makeAccountEnduringDataAV3 paedPersistingData paedEncryptedAmount paedReleaseSch -- for 'AccountV2'. rehashAccountEnduringDataAV2 :: (MonadBlobStore m) => - PersistentAccountEnduringData 'AccountV2 -> - m (PersistentAccountEnduringData 'AccountV2) + PersistentAccountEnduringData (MBSStore m) 'AccountV2 -> + m (PersistentAccountEnduringData (MBSStore m) 'AccountV2) rehashAccountEnduringDataAV2 ed = do amhi2PersistingAccountDataHash <- getHashM (paedPersistingData ed) (amhi2AccountStakeHash :: AccountStakeHash 'AccountV2) <- getHashM (paedStake ed) @@ -483,8 +490,8 @@ rehashAccountEnduringDataAV2 ed = do -- for 'AccountV3'. rehashAccountEnduringDataAV3 :: (MonadBlobStore m) => - PersistentAccountEnduringData 'AccountV3 -> - m (PersistentAccountEnduringData 'AccountV3) + PersistentAccountEnduringData (MBSStore m) 'AccountV3 -> + m (PersistentAccountEnduringData (MBSStore m) 'AccountV3) rehashAccountEnduringDataAV3 ed = do amhi3PersistingAccountDataHash <- getHashM (paedPersistingData ed) (amhi3AccountStakeHash :: AccountStakeHash 'AccountV3) <- getHashM (paedStake ed) @@ -502,8 +509,8 @@ rehashAccountEnduringDataAV3 ed = do rehashAccountEnduringData :: forall m av. (MonadBlobStore m, IsAccountVersion av, AccountStructureVersionFor av ~ 'AccountStructureV1) => - PersistentAccountEnduringData av -> - m (PersistentAccountEnduringData av) + PersistentAccountEnduringData (MBSStore m) av -> + m (PersistentAccountEnduringData (MBSStore m) av) rehashAccountEnduringData = case accountVersion @av of SAccountV2 -> rehashAccountEnduringDataAV2 SAccountV3 -> rehashAccountEnduringDataAV3 @@ -511,9 +518,9 @@ rehashAccountEnduringData = case accountVersion @av of -- | Compute the 'EnduringDataFlags' from a 'PersistentAccountEnduringData' for the purposes of -- storing the account. enduringDataFlags :: - forall av. + forall store av. (IsAccountVersion av) => - PersistentAccountEnduringData av -> + PersistentAccountEnduringData store av -> EnduringDataFlags av enduringDataFlags PersistentAccountEnduringData{..} = EnduringDataFlags @@ -614,7 +621,7 @@ data StakeFlags deriving (Eq, Ord, Show) -- | Get the 'StakeFlags' from a 'PersistentAccountStakeEnduring'. -stakeFlags :: PersistentAccountStakeEnduring av -> StakeFlags +stakeFlags :: PersistentAccountStakeEnduring store av -> StakeFlags stakeFlags PersistentAccountStakeEnduringNone = StakeFlagsNone stakeFlags PersistentAccountStakeEnduringBaker{..} = StakeFlagsBaker @@ -750,7 +757,7 @@ instance (IsAccountVersion av) => Serialize (EnduringDataFlags av) where -- - If flexible cooldown is supported and the value is @True@, a reference to the -- 'CooldownQueue'. -- - Otherwise, nothing. -instance (MonadBlobStore m, IsAccountVersion av) => BlobStorable m (PersistentAccountEnduringData av) where +instance (MonadBlobStore m, store ~ MBSStore m, IsAccountVersion av) => BlobStorable m (PersistentAccountEnduringData store av) where storeUpdate paed@PersistentAccountEnduringData{..} = do (ppd, newPersistingData) <- storeUpdate paedPersistingData (pea, newEncryptedAmount) <- storeUpdate paedEncryptedAmount @@ -839,7 +846,7 @@ instance (MonadBlobStore m, IsAccountVersion av) => BlobStorable m (PersistentAc -- are directly available. The rest of the fields are stored as part of the enduring data, -- under an 'EagerBufferedRef'. This limits the amount that needs to be rewritten for the -- most common updates. -data PersistentAccount av = PersistentAccount +data PersistentAccount store av = PersistentAccount { -- | The next nonce for transactions on the account. accountNonce :: !Nonce, -- | The total balance of the account. @@ -848,10 +855,10 @@ data PersistentAccount av = PersistentAccount -- INVARIANT: This is 0 if the account is not a baker or delegator. accountStakedAmount :: !Amount, -- | The enduring account data. - accountEnduringData :: !(EagerBufferedRef (PersistentAccountEnduringData av)) + accountEnduringData :: !(EagerBufferedRef store (PersistentAccountEnduringData store av)) } -instance HashableTo (AccountHash 'AccountV2) (PersistentAccount 'AccountV2) where +instance HashableTo (AccountHash 'AccountV2) (PersistentAccount store 'AccountV2) where getHash PersistentAccount{..} = makeAccountHash $ AHIV2 $ @@ -862,9 +869,9 @@ instance HashableTo (AccountHash 'AccountV2) (PersistentAccount 'AccountV2) wher ahi2MerkleHash = getHash accountEnduringData } -instance (Monad m) => MHashableTo m (AccountHash 'AccountV2) (PersistentAccount 'AccountV2) +instance (Monad m) => MHashableTo m (AccountHash 'AccountV2) (PersistentAccount store 'AccountV2) -instance HashableTo (AccountHash 'AccountV3) (PersistentAccount 'AccountV3) where +instance HashableTo (AccountHash 'AccountV3) (PersistentAccount store 'AccountV3) where getHash PersistentAccount{..} = makeAccountHash $ AHIV3 $ @@ -875,19 +882,22 @@ instance HashableTo (AccountHash 'AccountV3) (PersistentAccount 'AccountV3) wher ahi2MerkleHash = getHash accountEnduringData } -instance (Monad m) => MHashableTo m (AccountHash 'AccountV3) (PersistentAccount 'AccountV3) +instance (Monad m) => MHashableTo m (AccountHash 'AccountV3) (PersistentAccount store 'AccountV3) -instance HashableTo Hash.Hash (PersistentAccount 'AccountV2) where +instance HashableTo Hash.Hash (PersistentAccount store 'AccountV2) where getHash = theAccountHash @'AccountV2 . getHash -instance (Monad m) => MHashableTo m Hash.Hash (PersistentAccount 'AccountV2) +instance (Monad m) => MHashableTo m Hash.Hash (PersistentAccount store 'AccountV2) -instance HashableTo Hash.Hash (PersistentAccount 'AccountV3) where +instance HashableTo Hash.Hash (PersistentAccount store 'AccountV3) where getHash = theAccountHash @'AccountV3 . getHash -instance (Monad m) => MHashableTo m Hash.Hash (PersistentAccount 'AccountV3) +instance (Monad m) => MHashableTo m Hash.Hash (PersistentAccount store 'AccountV3) -instance (MonadBlobStore m, IsAccountVersion av) => BlobStorable m (PersistentAccount av) where +instance + (MonadBlobStore m, IsAccountVersion av, store ~ MBSStore m) => + BlobStorable m (PersistentAccount store av) + where storeUpdate acc@PersistentAccount{..} = do (pEnduringData, newEnduringData) <- storeUpdate accountEnduringData let p = do @@ -906,27 +916,27 @@ instance (MonadBlobStore m, IsAccountVersion av) => BlobStorable m (PersistentAc return $! PersistentAccount{..} -- | Get the enduring data for an account. -enduringData :: PersistentAccount av -> PersistentAccountEnduringData av +enduringData :: PersistentAccount store av -> PersistentAccountEnduringData store av enduringData = eagerBufferedDeref . accountEnduringData -- | Get the persisting data for an account. -persistingData :: PersistentAccount av -> PersistingAccountData +persistingData :: PersistentAccount store av -> PersistingAccountData persistingData = eagerBufferedDeref . paedPersistingData . enduringData -- ** Queries -- | Get the canonical address of the account. -getCanonicalAddress :: (Monad m) => PersistentAccount av -> m AccountAddress +getCanonicalAddress :: (Monad m) => PersistentAccount store av -> m AccountAddress getCanonicalAddress acc = do let pd = persistingData acc return $! pd ^. accountAddress -- | Get the current public account balance. -getAmount :: (Monad m) => PersistentAccount av -> m Amount +getAmount :: (Monad m) => PersistentAccount (MBSStore m) av -> m Amount getAmount = pure . accountAmount -- | Gets the amount of a baker's stake, or 'Nothing' if the account is not a baker. -getBakerStakeAmount :: (Monad m) => PersistentAccount av -> m (Maybe Amount) +getBakerStakeAmount :: (Monad m) => PersistentAccount (MBSStore m) av -> m (Maybe Amount) getBakerStakeAmount acc = do let ed = enduringData acc return $! case paedStake ed of @@ -934,20 +944,20 @@ getBakerStakeAmount acc = do _ -> Nothing -- | Get the amount that is actively staked on the account. -getActiveStakedAmount :: (Monad m) => PersistentAccount av -> m Amount +getActiveStakedAmount :: (Monad m) => PersistentAccount (MBSStore m) av -> m Amount getActiveStakedAmount acc = return $! accountStakedAmount acc -- | Get the total amount that is staked on the account including the active stake (for a validator -- or delegator) and the inactive stake (in cooldown). -- For account versions prior to 'AccountV3', this is the same as 'getActiveStakedAmount'. -getTotalStakedAmount :: (Monad m) => PersistentAccount av -> m Amount +getTotalStakedAmount :: (Monad m) => PersistentAccount (MBSStore m) av -> m Amount getTotalStakedAmount acc = return $! activeStake + inactiveStake where activeStake = accountStakedAmount acc inactiveStake = cooldownStake $ paedStakeCooldown (enduringData acc) -- | Get the amount that is locked in scheduled releases on the account. -getLockedAmount :: (Monad m) => PersistentAccount av -> m Amount +getLockedAmount :: (Monad m) => PersistentAccount (MBSStore m) av -> m Amount getLockedAmount acc = do let ed = enduringData acc return $! paedLockedAmount ed @@ -956,7 +966,7 @@ getLockedAmount acc = do -- This accounts for lock-up and staked amounts. -- @available = total - max locked staked@ where -- @staked = active + inactive@. -getAvailableAmount :: (Monad m) => PersistentAccount av -> m Amount +getAvailableAmount :: (Monad m) => PersistentAccount (MBSStore m) av -> m Amount getAvailableAmount acc = do let ed = enduringData acc activeStake = accountStakedAmount acc @@ -965,7 +975,7 @@ getAvailableAmount acc = do return $! accountAmount acc - max stake (paedLockedAmount ed) -- | Get the next account nonce for transactions from this account. -getNonce :: (Monad m) => PersistentAccount av -> m Nonce +getNonce :: (Monad m) => PersistentAccount (MBSStore m) av -> m Nonce getNonce = pure . accountNonce -- | Determine if a given operation is permitted for the account. @@ -973,7 +983,7 @@ getNonce = pure . accountNonce -- * For 'AllowedEncryptedTransfers' the account may only have 1 credential. -- -- * For 'AllowedMultipleCredentials' the account must have the empty encrypted balance. -isAllowed :: (MonadBlobStore m) => PersistentAccount av -> AccountAllowance -> m Bool +isAllowed :: (MonadBlobStore m) => PersistentAccount (MBSStore m) av -> AccountAllowance -> m Bool isAllowed acc AllowedEncryptedTransfers = do creds <- getCredentials acc return $! Map.size creds == 1 @@ -986,19 +996,19 @@ isAllowed acc AllowedMultipleCredentials = do -- | Get the credentials deployed on the account. This map is always non-empty and (presently) -- will have a credential at index 'initialCredentialIndex' (0) that cannot be changed. -getCredentials :: (Monad m) => PersistentAccount av -> m (Map.Map CredentialIndex RawAccountCredential) +getCredentials :: (Monad m) => PersistentAccount (MBSStore m) av -> m (Map.Map CredentialIndex RawAccountCredential) getCredentials acc = do let pd = persistingData acc return $! pd ^. accountCredentials -- | Get the key used to verify transaction signatures, it records the signature scheme used as well. -getVerificationKeys :: (Monad m) => PersistentAccount av -> m AccountInformation +getVerificationKeys :: (Monad m) => PersistentAccount (MBSStore m) av -> m AccountInformation getVerificationKeys acc = do let pd = persistingData acc return $! pd ^. accountVerificationKeys -- | Get the current encrypted amount on the account. -getEncryptedAmount :: (MonadBlobStore m) => PersistentAccount av -> m AccountEncryptedAmount +getEncryptedAmount :: (MonadBlobStore m) => PersistentAccount (MBSStore m) av -> m AccountEncryptedAmount getEncryptedAmount acc = do let ed = enduringData acc case paedEncryptedAmount ed of @@ -1006,7 +1016,7 @@ getEncryptedAmount acc = do Some ea -> loadPersistentAccountEncryptedAmount =<< refLoad ea -- | Get the public key used to receive encrypted amounts. -getEncryptionKey :: (MonadBlobStore f) => PersistentAccount av -> f AccountEncryptionKey +getEncryptionKey :: (MonadBlobStore f) => PersistentAccount (MBSStore f) av -> f AccountEncryptionKey getEncryptionKey acc = do let pd = persistingData acc -- The use of the unsafe @unsafeEncryptionKeyFromRaw@ function here is @@ -1015,7 +1025,7 @@ getEncryptionKey acc = do return $! unsafeEncryptionKeyFromRaw (pd ^. accountEncryptionKey) -- | Get the release schedule for an account. -getReleaseSummary :: (MonadBlobStore m) => PersistentAccount av -> m AccountReleaseSummary +getReleaseSummary :: (MonadBlobStore m) => PersistentAccount (MBSStore m) av -> m AccountReleaseSummary getReleaseSummary acc = do let ed = enduringData acc case paedReleaseSchedule ed of @@ -1023,7 +1033,7 @@ getReleaseSummary acc = do Some (rsRef, _) -> toAccountReleaseSummary =<< refLoad rsRef -- | Get the release schedule for an account. -getReleaseSchedule :: (MonadBlobStore m, IsAccountVersion av, AccountStructureVersionFor av ~ 'AccountStructureV1) => PersistentAccount av -> m (TARS.AccountReleaseSchedule av) +getReleaseSchedule :: (MonadBlobStore m, IsAccountVersion av, AccountStructureVersionFor av ~ 'AccountStructureV1) => PersistentAccount (MBSStore m) av -> m (TARS.AccountReleaseSchedule av) getReleaseSchedule acc = do let ed = enduringData acc TARS.fromAccountReleaseScheduleV1 <$> case paedReleaseSchedule ed of @@ -1031,7 +1041,7 @@ getReleaseSchedule acc = do Some (rsRef, total) -> getAccountReleaseSchedule total =<< refLoad rsRef -- | Get the timestamp at which the next scheduled release will occur (if any). -getNextReleaseTimestamp :: (MonadBlobStore m) => PersistentAccount av -> m (Maybe Timestamp) +getNextReleaseTimestamp :: (MonadBlobStore m) => PersistentAccount (MBSStore m) av -> m (Maybe Timestamp) getNextReleaseTimestamp acc = do let ed = enduringData acc case paedReleaseSchedule ed of @@ -1039,7 +1049,7 @@ getNextReleaseTimestamp acc = do Some (rsRef, _) -> nextReleaseTimestamp <$!> refLoad rsRef -- | Get the baker (if any) attached to an account. -getBaker :: (MonadBlobStore m, IsAccountVersion av, AVSupportsDelegation av) => PersistentAccount av -> m (Maybe (AccountBaker av)) +getBaker :: (MonadBlobStore m, IsAccountVersion av, AVSupportsDelegation av) => PersistentAccount (MBSStore m) av -> m (Maybe (AccountBaker av)) getBaker acc = do let ed = enduringData acc case paedStake ed of @@ -1058,8 +1068,8 @@ getBaker acc = do -- | Get a reference to the baker info (if any) attached to an account. getBakerInfoRef :: (MonadBlobStore m) => - PersistentAccount av -> - m (Maybe (PersistentBakerInfoEx av)) + PersistentAccount (MBSStore m) av -> + m (Maybe (PersistentBakerInfoEx (MBSStore m) av)) getBakerInfoRef acc = do let ed = enduringData acc case paedStake ed of @@ -1067,7 +1077,7 @@ getBakerInfoRef acc = do _ -> return Nothing -- | Get the baker and baker info reference (if any) attached to the account. -getBakerAndInfoRef :: (MonadBlobStore m, IsAccountVersion av, AVSupportsDelegation av) => PersistentAccount av -> m (Maybe (AccountBaker av, PersistentBakerInfoEx av)) +getBakerAndInfoRef :: (MonadBlobStore m, IsAccountVersion av, AVSupportsDelegation av) => PersistentAccount (MBSStore m) av -> m (Maybe (AccountBaker av, PersistentBakerInfoEx (MBSStore m) av)) getBakerAndInfoRef acc = do let ed = enduringData acc case paedStake ed of @@ -1084,7 +1094,7 @@ getBakerAndInfoRef acc = do _ -> return Nothing -- | Get the delegator (if any) attached to the account. -getDelegator :: (MonadBlobStore m, AVSupportsDelegation av) => PersistentAccount av -> m (Maybe (AccountDelegation av)) +getDelegator :: (MonadBlobStore m, AVSupportsDelegation av) => PersistentAccount (MBSStore m) av -> m (Maybe (AccountDelegation av)) getDelegator acc = do let ed = enduringData acc case paedStake ed of @@ -1103,20 +1113,20 @@ getDelegator acc = do -- | Get the baker or stake delegation information attached to an account. getStake :: (MonadBlobStore m, IsAccountVersion av, AVSupportsDelegation av) => - PersistentAccount av -> + PersistentAccount (MBSStore m) av -> m (AccountStake av) getStake acc = do let ed = enduringData acc persistentToAccountStake (paedStake ed) (accountStakedAmount acc) -- | Determine if an account has stake as a baker or delegator. -hasActiveStake :: PersistentAccount av -> Bool +hasActiveStake :: PersistentAccount store av -> Bool hasActiveStake acc = case paedStake (enduringData acc) of PersistentAccountStakeEnduringNone -> False _ -> True -- | Get details about an account's stake. -getStakeDetails :: (MonadBlobStore m, AVSupportsDelegation av) => PersistentAccount av -> m (StakeDetails av) +getStakeDetails :: (MonadBlobStore m, AVSupportsDelegation av) => PersistentAccount (MBSStore m) av -> m (StakeDetails av) getStakeDetails acc = do let ed = enduringData acc return $! case paedStake ed of @@ -1137,15 +1147,15 @@ getStakeDetails acc = do getStakeCooldown :: (MonadBlobStore m) => - PersistentAccount av -> - m (CooldownQueue av) + PersistentAccount (MBSStore m) av -> + m (CooldownQueue (MBSStore m) av) getStakeCooldown acc = do let ed = enduringData acc return $ paedStakeCooldown ed getCooldowns :: (MonadBlobStore m, AVSupportsFlexibleCooldown av) => - PersistentAccount av -> + PersistentAccount (MBSStore m) av -> m (Maybe Cooldowns) getCooldowns = getStakeCooldown >=> \case @@ -1162,8 +1172,8 @@ updateAccount :: AccountStructureVersionFor av ~ 'AccountStructureV1 ) => AccountUpdate -> - PersistentAccount av -> - m (PersistentAccount av) + PersistentAccount (MBSStore m) av -> + m (PersistentAccount (MBSStore m) av) updateAccount !upd !acc0 = do let ed0 = enduringData acc0 (ed1, enduringRehash1, additionalLocked) <- case upd ^. auReleaseSchedule of @@ -1223,9 +1233,9 @@ updateAccount !upd !acc0 = do -- recomputing the hash. updateEnduringData :: (MonadBlobStore m, IsAccountVersion av, AccountStructureVersionFor av ~ 'AccountStructureV1) => - (PersistentAccountEnduringData av -> m (PersistentAccountEnduringData av)) -> - PersistentAccount av -> - m (PersistentAccount av) + (PersistentAccountEnduringData (MBSStore m) av -> m (PersistentAccountEnduringData (MBSStore m) av)) -> + PersistentAccount (MBSStore m) av -> + m (PersistentAccount (MBSStore m) av) updateEnduringData f acc = do let ed = enduringData acc newEnduring <- refMake =<< rehashAccountEnduringData =<< f ed @@ -1235,8 +1245,8 @@ updateEnduringData f acc = do updatePersistingData :: (MonadBlobStore m, IsAccountVersion av, AccountStructureVersionFor av ~ 'AccountStructureV1) => (PersistingAccountData -> PersistingAccountData) -> - PersistentAccount av -> - m (PersistentAccount av) + PersistentAccount (MBSStore m) av -> + m (PersistentAccount (MBSStore m) av) updatePersistingData f = updateEnduringData $ \ed -> do let pd = eagerBufferedDeref (paedPersistingData ed) newPersisting <- refMake $! f pd @@ -1245,9 +1255,9 @@ updatePersistingData f = updateEnduringData $ \ed -> do -- | Helper function. Update the 'PersistentAccountStakeEnduring' component of an account. updateStake :: (MonadBlobStore m, IsAccountVersion av, AccountStructureVersionFor av ~ 'AccountStructureV1) => - (PersistentAccountStakeEnduring av -> m (PersistentAccountStakeEnduring av)) -> - PersistentAccount av -> - m (PersistentAccount av) + (PersistentAccountStakeEnduring (MBSStore m) av -> m (PersistentAccountStakeEnduring (MBSStore m) av)) -> + PersistentAccount (MBSStore m) av -> + m (PersistentAccount (MBSStore m) av) updateStake f = updateEnduringData $ \ed -> do newStake <- f (paedStake ed) return $! ed{paedStake = newStake} @@ -1269,8 +1279,8 @@ updateAccountCredentials :: -- | New account threshold AccountThreshold -> -- | Account to update - PersistentAccount av -> - m (PersistentAccount av) + PersistentAccount (MBSStore m) av -> + m (PersistentAccount (MBSStore m) av) updateAccountCredentials cuRemove cuAdd cuAccountThreshold = updatePersistingData (updateCredentials cuRemove cuAdd cuAccountThreshold) @@ -1283,12 +1293,12 @@ updateAccountCredentialKeys :: -- | New public keys CredentialPublicKeys -> -- | Account to update - PersistentAccount av -> - m (PersistentAccount av) + PersistentAccount (MBSStore m) av -> + m (PersistentAccount (MBSStore m) av) updateAccountCredentialKeys credIndex credKeys = updatePersistingData (updateCredentialKeys credIndex credKeys) -- | Add an amount to the account's balance. -addAmount :: (Monad m) => Amount -> PersistentAccount av -> m (PersistentAccount av) +addAmount :: (Monad m) => Amount -> PersistentAccount (MBSStore m) av -> m (PersistentAccount (MBSStore m) av) addAmount !amt acc = return $! acc{accountAmount = accountAmount acc + amt} -- | Add a baker to an account for account version 1. @@ -1302,8 +1312,8 @@ addBakerV1 :: -- | Whether earnings are restaked Bool -> -- | Account to add baker to - PersistentAccount av -> - m (PersistentAccount av) + PersistentAccount (MBSStore m) av -> + m (PersistentAccount (MBSStore m) av) addBakerV1 binfo stake restake acc = do let ed = enduringData acc binfoRef <- refMake $! binfo @@ -1325,8 +1335,8 @@ addBakerV1 binfo stake restake acc = do addDelegator :: (MonadBlobStore m, IsAccountVersion av, AccountStructureVersionFor av ~ 'AccountStructureV1) => AccountDelegation av -> - PersistentAccount av -> - m (PersistentAccount av) + PersistentAccount (MBSStore m) av -> + m (PersistentAccount (MBSStore m) av) addDelegator AccountDelegationV1{..} acc = do let ed = enduringData acc let del = @@ -1352,8 +1362,8 @@ updateBakerPoolInfo :: AccountStructureVersionFor av ~ 'AccountStructureV1 ) => BakerPoolInfoUpdate -> - PersistentAccount av -> - m (PersistentAccount av) + PersistentAccount (MBSStore m) av -> + m (PersistentAccount (MBSStore m) av) updateBakerPoolInfo upd = updateEnduringData $ \ed -> case paedStake ed of baker@PersistentAccountStakeEnduringBaker{} -> do oldInfo <- refLoad (paseBakerInfo baker) @@ -1374,8 +1384,8 @@ setBakerKeys :: AccountStructureVersionFor av ~ 'AccountStructureV1 ) => BakerKeyUpdate -> - PersistentAccount av -> - m (PersistentAccount av) + PersistentAccount (MBSStore m) av -> + m (PersistentAccount (MBSStore m) av) setBakerKeys upd = updateStake $ \case baker@PersistentAccountStakeEnduringBaker{} -> do oldInfo <- refLoad (paseBakerInfo baker) @@ -1399,8 +1409,8 @@ setBakerKeys upd = updateStake $ \case setStake :: (Monad m) => Amount -> - PersistentAccount av -> - m (PersistentAccount av) + PersistentAccount (MBSStore m) av -> + m (PersistentAccount (MBSStore m) av) setStake newStake acc = return $! acc{accountStakedAmount = newStake} -- | Add a specified amount to the pre-pre-cooldown inactive stake. @@ -1412,8 +1422,8 @@ addPrePreCooldown :: AVSupportsFlexibleCooldown av ) => Amount -> - PersistentAccount av -> - m (PersistentAccount av) + PersistentAccount (MBSStore m) av -> + m (PersistentAccount (MBSStore m) av) addPrePreCooldown amt = updateEnduringData $ \ed -> do newStakeCooldown <- CooldownQueue.addPrePreCooldown amt (paedStakeCooldown ed) return $! ed{paedStakeCooldown = newStakeCooldown} @@ -1427,8 +1437,8 @@ reactivateCooldownAmount :: AVSupportsFlexibleCooldown av ) => Amount -> - PersistentAccount av -> - m (PersistentAccount av) + PersistentAccount (MBSStore m) av -> + m (PersistentAccount (MBSStore m) av) reactivateCooldownAmount amt acc = case paedStakeCooldown (enduringData acc) of EmptyCooldownQueue -> return acc _ -> updateEnduringData reactivate acc @@ -1442,8 +1452,8 @@ reactivateCooldownAmount amt acc = case paedStakeCooldown (enduringData acc) of setRestakeEarnings :: (MonadBlobStore m, IsAccountVersion av, AccountStructureVersionFor av ~ 'AccountStructureV1) => Bool -> - PersistentAccount av -> - m (PersistentAccount av) + PersistentAccount (MBSStore m) av -> + m (PersistentAccount (MBSStore m) av) setRestakeEarnings newRestake = updateStake $ return . \case @@ -1458,8 +1468,8 @@ setRestakeEarnings newRestake = setStakePendingChange :: (MonadBlobStore m, IsAccountVersion av, AccountStructureVersionFor av ~ 'AccountStructureV1) => StakePendingChange av -> - PersistentAccount av -> - m (PersistentAccount av) + PersistentAccount (MBSStore m) av -> + m (PersistentAccount (MBSStore m) av) setStakePendingChange newPC = updateStake $ return . \case @@ -1474,8 +1484,8 @@ setStakePendingChange newPC = setDelegationTarget :: (MonadBlobStore m, IsAccountVersion av, AccountStructureVersionFor av ~ 'AccountStructureV1) => DelegationTarget -> - PersistentAccount av -> - m (PersistentAccount av) + PersistentAccount (MBSStore m) av -> + m (PersistentAccount (MBSStore m) av) setDelegationTarget newTarget = updateStake $ return . \case @@ -1489,8 +1499,8 @@ setDelegationTarget newTarget = -- | Remove any staking on an account. removeStaking :: (MonadBlobStore m, IsAccountVersion av, AccountStructureVersionFor av ~ 'AccountStructureV1) => - PersistentAccount av -> - m (PersistentAccount av) + PersistentAccount (MBSStore m) av -> + m (PersistentAccount (MBSStore m) av) removeStaking acc0 = do acc1 <- updateStake (const $ return PersistentAccountStakeEnduringNone) acc0 return $! acc1{accountStakedAmount = 0} @@ -1504,8 +1514,8 @@ setCommissionRates :: AccountStructureVersionFor av ~ 'AccountStructureV1 ) => CommissionRates -> - PersistentAccount av -> - m (PersistentAccount av) + PersistentAccount (MBSStore m) av -> + m (PersistentAccount (MBSStore m) av) setCommissionRates rates = updateStake $ \case baker@PersistentAccountStakeEnduringBaker{} -> do oldInfo <- refLoad (paseBakerInfo baker) @@ -1523,8 +1533,8 @@ setCommissionRates rates = updateStake $ \case unlockReleases :: (MonadBlobStore m, IsAccountVersion av, AccountStructureVersionFor av ~ 'AccountStructureV1) => Timestamp -> - PersistentAccount av -> - m (Maybe Timestamp, PersistentAccount av) + PersistentAccount (MBSStore m) av -> + m (Maybe Timestamp, PersistentAccount (MBSStore m) av) unlockReleases ts acc = do let ed = enduringData acc case paedReleaseSchedule ed of @@ -1555,8 +1565,8 @@ processCooldownsUntil :: ) => -- | Release all cooldowns up to and including this timestamp. Timestamp -> - PersistentAccount av -> - m (Maybe Timestamp, PersistentAccount av) + PersistentAccount (MBSStore m) av -> + m (Maybe Timestamp, PersistentAccount (MBSStore m) av) processCooldownsUntil ts acc = do let ed = enduringData acc (nextTimestamp, newQueue) <- CooldownQueue.processCooldownsUntil ts (paedStakeCooldown ed) @@ -1577,8 +1587,8 @@ processPreCooldown :: AccountStructureVersionFor av ~ 'AccountStructureV1 ) => Timestamp -> - PersistentAccount av -> - m (NextCooldownChange, PersistentAccount av) + PersistentAccount (MBSStore m) av -> + m (NextCooldownChange, PersistentAccount (MBSStore m) av) processPreCooldown ts acc = do let ed = enduringData acc (res, newQueue) <- CooldownQueue.processPreCooldown ts (paedStakeCooldown ed) @@ -1598,8 +1608,8 @@ processPrePreCooldown :: IsAccountVersion av, AccountStructureVersionFor av ~ 'AccountStructureV1 ) => - PersistentAccount av -> - m (PersistentAccount av) + PersistentAccount (MBSStore m) av -> + m (PersistentAccount (MBSStore m) av) processPrePreCooldown acc = do let ed = enduringData acc newQueue <- CooldownQueue.processPrePreCooldown (paedStakeCooldown ed) @@ -1617,9 +1627,9 @@ makePersistentAccount :: TARS.AccountReleaseSchedule' av ~ TARSV1.AccountReleaseSchedule ) => Transient.Account av -> - m (PersistentAccount av) + m (PersistentAccount (MBSStore m) av) makePersistentAccount Transient.Account{..} = do - paedPersistingData :: EagerBufferedRef PersistingAccountData <- refMake $! _unhashed _accountPersisting + paedPersistingData :: EagerBufferedRef (MBSStore m) PersistingAccountData <- refMake $! _unhashed _accountPersisting (accountStakedAmount, !paedStake) <- case _accountStaking of AccountStakeNone -> return (0, PersistentAccountStakeEnduringNone) AccountStakeBaker AccountBaker{..} -> do @@ -1640,13 +1650,13 @@ makePersistentAccount Transient.Account{..} = do paseDelegatorPendingChange = _delegationPendingChange } return (_delegationStakedAmount, del) - paedEncryptedAmount :: Nullable (LazyBufferedRef PersistentAccountEncryptedAmount) <- do + paedEncryptedAmount :: Nullable (LazyBufferedRef (MBSStore m) (PersistentAccountEncryptedAmount (MBSStore m))) <- do ea <- storePersistentAccountEncryptedAmount _accountEncryptedAmount isInit <- isInitialPersistentAccountEncryptedAmount ea if isInit then return Null else Some <$!> refMake ea - paedReleaseSchedule :: Nullable (LazyBufferedRef AccountReleaseSchedule, Amount) <- do + paedReleaseSchedule :: Nullable (LazyBufferedRef (MBSStore m) (AccountReleaseSchedule (MBSStore m)), Amount) <- do rs <- makePersistentAccountReleaseSchedule (TARS.theAccountReleaseSchedule _accountReleaseSchedule) if isEmptyAccountReleaseSchedule rs then return Null @@ -1688,7 +1698,7 @@ newAccount :: GlobalContext -> AccountAddress -> AccountCredential -> - m (PersistentAccount av) + m (PersistentAccount (MBSStore m) av) newAccount cryptoParams _accountAddress credential = do let creds = Map.singleton initialCredentialIndex credential let newPData = @@ -1699,7 +1709,7 @@ newAccount cryptoParams _accountAddress credential = do _accountRemovedCredentials = emptyHashedRemovedCredentials, .. } - paedPersistingData :: EagerBufferedRef PersistingAccountData <- refMake newPData + paedPersistingData :: EagerBufferedRef (MBSStore m) PersistingAccountData <- refMake newPData accountEnduringData <- refMake =<< case accountVersion @av of @@ -1737,9 +1747,9 @@ makeFromGenesisAccount :: GlobalContext -> ChainParameters pv -> GenesisAccount -> - m (PersistentAccount av) + m (PersistentAccount (MBSStore m) av) makeFromGenesisAccount spv cryptoParams chainParameters GenesisAccount{..} = do - paedPersistingData :: EagerBufferedRef PersistingAccountData <- + paedPersistingData :: EagerBufferedRef (MBSStore m) PersistingAccountData <- refMakeFlushed $ PersistingAccountData { _accountEncryptionKey = @@ -1792,8 +1802,8 @@ makeFromGenesisAccount spv cryptoParams chainParameters GenesisAccount{..} = do migrateEnduringDataV2 :: (SupportMigration m t, MonadLogger (t m)) => - PersistentAccountEnduringData 'AccountV2 -> - t m (PersistentAccountEnduringData 'AccountV2) + PersistentAccountEnduringData (MBSStore m) 'AccountV2 -> + t m (PersistentAccountEnduringData (MBSStore (t m)) 'AccountV2) migrateEnduringDataV2 ed = do paedPersistingData <- migrateEagerBufferedRef return (paedPersistingData ed) paedEncryptedAmount <- forM (paedEncryptedAmount ed) $ migrateReference migratePersistentEncryptedAmount @@ -1824,9 +1834,9 @@ migrateEnduringDataV2 ed = do migrateEnduringDataV2toV3 :: (SupportMigration m t, AccountMigration 'AccountV3 (t m), MonadLogger (t m)) => -- | Current enduring data - PersistentAccountEnduringData 'AccountV2 -> + PersistentAccountEnduringData (MBSStore m) 'AccountV2 -> -- | New enduring data. - StakedBalanceStateTT t m (PersistentAccountEnduringData 'AccountV3) + StakedBalanceStateTT t m (PersistentAccountEnduringData (MBSStore (t m)) 'AccountV3) migrateEnduringDataV2toV3 ed = do logEvent GlobalState LLTrace "Migrating persisting data" paedPersistingData <- migrateEagerBufferedRef return (paedPersistingData ed) @@ -1851,8 +1861,8 @@ migrateEnduringDataV2toV3 ed = do -- The data is unchanged in the migration. migrateEnduringDataV3toV3 :: (SupportMigration m t, MonadLogger (t m)) => - PersistentAccountEnduringData 'AccountV3 -> - t m (PersistentAccountEnduringData 'AccountV3) + PersistentAccountEnduringData (MBSStore m) 'AccountV3 -> + t m (PersistentAccountEnduringData (MBSStore (t m)) 'AccountV3) migrateEnduringDataV3toV3 ed = do paedPersistingData <- migrateEagerBufferedRef return (paedPersistingData ed) paedEncryptedAmount <- forM (paedEncryptedAmount ed) $ migrateReference migratePersistentEncryptedAmount @@ -1871,8 +1881,8 @@ migrateV2ToV2 :: MonadTrans t, MonadLogger (t m) ) => - PersistentAccount 'AccountV2 -> - t m (PersistentAccount 'AccountV2) + PersistentAccount (MBSStore m) 'AccountV2 -> + t m (PersistentAccount (MBSStore (t m)) 'AccountV2) migrateV2ToV2 acc = do accountEnduringData <- migrateEagerBufferedRef migrateEnduringDataV2 (accountEnduringData acc) return $! @@ -1906,8 +1916,8 @@ migrateV2ToV3 :: MonadTrans t, MonadLogger (t m) ) => - PersistentAccount 'AccountV2 -> - t m (PersistentAccount 'AccountV3) + PersistentAccount (MBSStore m) 'AccountV2 -> + t m (PersistentAccount (MBSStore (t m)) 'AccountV3) migrateV2ToV3 acc = do (accountEnduringData, newStakedAmount) <- runStakedBalanceStateTT @@ -1929,8 +1939,8 @@ migrateV3ToV3 :: MonadTrans t, MonadLogger (t m) ) => - PersistentAccount 'AccountV3 -> - t m (PersistentAccount 'AccountV3) + PersistentAccount (MBSStore m) 'AccountV3 -> + t m (PersistentAccount (MBSStore (t m)) 'AccountV3) migrateV3ToV3 acc = do accountEnduringData <- migrateEagerBufferedRef migrateEnduringDataV3toV3 (accountEnduringData acc) return $! @@ -1965,8 +1975,8 @@ migratePersistentAccount :: MonadLogger (t m) ) => StateMigrationParameters oldpv pv -> - PersistentAccount (AccountVersionFor oldpv) -> - t m (PersistentAccount (AccountVersionFor pv)) + PersistentAccount (MBSStore m) (AccountVersionFor oldpv) -> + t m (PersistentAccount (MBSStore (t m)) (AccountVersionFor pv)) migratePersistentAccount StateMigrationParametersTrivial acc = case accountVersion @(AccountVersionFor oldpv) of SAccountV2 -> migrateV2ToV2 acc SAccountV3 -> migrateV3ToV3 acc @@ -1982,8 +1992,8 @@ migratePersistentAccountFromV0 :: MonadLogger (t m) ) => StateMigrationParameters oldpv pv -> - V0.PersistentAccount (AccountVersionFor oldpv) -> - t m (PersistentAccount (AccountVersionFor pv)) + V0.PersistentAccount (MBSStore m) (AccountVersionFor oldpv) -> + t m (PersistentAccount (MBSStore (t m)) (AccountVersionFor pv)) migratePersistentAccountFromV0 StateMigrationParametersP4ToP5{} V0.PersistentAccount{..} = do paedPersistingData <- migrateReference return _persistingData (accountStakedAmount, !paedStake) <- case _accountStake of @@ -2005,7 +2015,8 @@ migratePersistentAccountFromV0 StateMigrationParametersP4ToP5{} V0.PersistentAcc return (_stakedAmount, baker) V0.PersistentAccountStakeDelegate dlgRef -> do AccountDelegationV1{..} <- lift $ refLoad dlgRef - let del :: PersistentAccountStakeEnduring 'AccountV2 + let + -- del :: PersistentAccountStakeEnduring _ 'AccountV2 del = PersistentAccountStakeEnduringDelegator { paseDelegatorRestakeEarnings = _delegationStakeEarnings, @@ -2054,7 +2065,7 @@ toTransientAccount :: AccountStructureVersionFor av ~ 'AccountStructureV1, AVSupportsDelegation av ) => - PersistentAccount av -> + PersistentAccount (MBSStore m) av -> m (Transient.Account av) toTransientAccount acc = do let _accountPersisting = makeHashed $ persistingData acc diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs index 908fe9e75e..8c8acef290 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs @@ -42,7 +42,7 @@ -- 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 +-- When a block state is thawed (made ready for modification), then a new 'DiffMap.DifferenceMap' is created for the @Accounts store 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@. @@ -119,11 +119,11 @@ import Data.Serialize -- since it requires the key to be available when loading the account from the reference, and -- 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 +data Accounts store (pv :: ProtocolVersion) = Accounts { -- | Hashed Merkle-tree of the accounts - accountTable :: !(LFMBTree' AccountIndex HashedBufferedRef (AccountRef (AccountVersionFor pv))), + accountTable :: !(LFMBTree' AccountIndex (HashedBufferedRef store) (AccountRef store (AccountVersionFor pv))), -- | Persisted representation of the map from registration ids to account indices. - accountRegIdHistory :: !(Trie.TrieN UnbufferedFix ID.RawCredentialRegistrationID AccountIndex), + accountRegIdHistory :: !(Trie.TrieN (UnbufferedFix store) ID.RawCredentialRegistrationID AccountIndex), -- | 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 @@ -131,20 +131,21 @@ data Accounts (pv :: ProtocolVersion) = Accounts accountDiffMapRef :: !DiffMap.DifferenceMapReference } -instance (IsProtocolVersion pv) => Show (Accounts pv) where +instance (IsProtocolVersion pv) => Show (Accounts store pv) where 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 -- the account cache and 'MonadAccountMapStore' for the persistent account map. -type SupportsPersistentAccount pv m = +type SupportsPersistentAccount store pv m = ( IsProtocolVersion pv, MonadBlobStore m, - MonadCache (AccountCache (AccountVersionFor pv)) m, - LMDBAccountMap.MonadAccountMapStore m + MonadCache (AccountCache (MBSStore m) (AccountVersionFor pv)) m, + LMDBAccountMap.MonadAccountMapStore m, + store ~ MBSStore m ) -instance (SupportsPersistentAccount pv m) => MHashableTo m (AccountsHash pv) (Accounts pv) where +instance (SupportsPersistentAccount store pv m) => MHashableTo m (AccountsHash pv) (Accounts store pv) where getHashM Accounts{..} = AccountsHash . theLFMBTreeHash <$> getHashM @m @(LFMBTreeHash pv) accountTable @@ -152,7 +153,7 @@ instance (SupportsPersistentAccount pv m) => MHashableTo m (AccountsHash pv) (Ac -- | 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 whenever a block is finalized. -writeAccountsCreated :: (SupportsPersistentAccount pv m) => Accounts pv -> m () +writeAccountsCreated :: (SupportsPersistentAccount store pv m) => Accounts store pv -> m () writeAccountsCreated Accounts{..} = do mAccountsCreated <- liftIO $ readIORef accountDiffMapRef forM_ mAccountsCreated $ \accountsCreated -> do @@ -164,15 +165,15 @@ writeAccountsCreated Accounts{..} = 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 difference map of the provided @Accounts pv@. -mkNewChildDifferenceMap :: (SupportsPersistentAccount pv m) => Accounts pv -> m (Accounts pv) +-- | Create a new @Accounts store pv@ structure from the provided one. +-- This function creates a new 'DiffMap.DifferenceMap' for the resulting @Accounts store pv@ which +-- has a reference to the difference map of the provided @Accounts store pv@. +mkNewChildDifferenceMap :: (SupportsPersistentAccount store pv m) => Accounts store pv -> m (Accounts store 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@. +-- | Create and set the 'DiffMap.DifferenceMap' for the provided @Accounts store 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. -- @@ -184,14 +185,14 @@ mkNewChildDifferenceMap accts@Accounts{..} = do -- * 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 :: - (SupportsPersistentAccount pv m) => + (SupportsPersistentAccount store pv m) => -- | 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 -> + Accounts store pv -> -- | Reference to the newly created difference map. m DiffMap.DifferenceMapReference reconstructDifferenceMap parentRef listOfAccounts Accounts{..} = do @@ -211,7 +212,7 @@ reconstructDifferenceMap parentRef listOfAccounts Accounts{..} = do storeRequiresAccountMap :: SProtocolVersion pv -> Bool storeRequiresAccountMap spv = demoteProtocolVersion spv <= P6 -instance (SupportsPersistentAccount pv m) => BlobStorable m (Accounts pv) where +instance (SupportsPersistentAccount store pv m) => BlobStorable m (Accounts store pv) where storeUpdate Accounts{..} = do -- put an empty 'OldMap.PersistentAccountMap'. -- In earlier versions of the node the above mentioned account map was used, @@ -219,7 +220,7 @@ instance (SupportsPersistentAccount pv m) => BlobStorable m (Accounts pv) where -- We put this empty map here if the protocol version requires it in order to remain backwards compatible. pAccountMap <- if storeRequiresAccountMap (protocolVersion @pv) - then fst <$> storeUpdate (OldMap.empty @pv @BufferedFix) + then fst <$> storeUpdate (OldMap.empty @pv @(BufferedFix store)) else return (return ()) (pTable, accountTable') <- storeUpdate accountTable (pRegIdHistory, regIdHistory') <- storeUpdate accountRegIdHistory @@ -234,7 +235,7 @@ instance (SupportsPersistentAccount pv m) => BlobStorable m (Accounts pv) where -- 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))) + void (load :: Get (m (OldMap.PersistentAccountMap store pv))) maccountTable <- load mrRIH <- load return $ do @@ -243,34 +244,42 @@ instance (SupportsPersistentAccount pv m) => BlobStorable m (Accounts pv) where accountDiffMapRef <- DiffMap.newEmptyReference return $ Accounts{..} -instance (SupportsPersistentAccount pv m, av ~ AccountVersionFor pv) => Cacheable1 m (Accounts pv) (PersistentAccount av) where +instance + (SupportsPersistentAccount store pv m, av ~ AccountVersionFor pv) => + Cacheable1 m (Accounts store pv) (PersistentAccount store av) + where liftCache cch accts@Accounts{..} = do - acctTable <- liftCache (liftCache @_ @(HashedCachedRef (AccountCache av) (PersistentAccount av)) cch) accountTable + acctTable <- liftCache (liftCache @_ @(HashedCachedRef store (AccountCache store av) (PersistentAccount store av)) cch) accountTable return accts{accountTable = acctTable} -- This instance is here so we can cache the account table when starting up, -- allowing for efficient modification of the state. -instance (SupportsPersistentAccount pv m) => Cacheable m (Accounts pv) where +instance (SupportsPersistentAccount store pv m) => Cacheable m (Accounts store pv) where cache accts = do let atLeaf = return @_ @( HashedCachedRef - (AccountCache (AccountVersionFor pv)) - (PersistentAccount (AccountVersionFor pv)) + store + (AccountCache store (AccountVersionFor pv)) + (PersistentAccount store (AccountVersionFor pv)) ) acctTable <- liftCache atLeaf (accountTable accts) return accts{accountTable = acctTable} -- | Create a new empty 'Accounts' structure. -emptyAccounts :: (MonadIO m) => m (Accounts pv) +emptyAccounts :: (MonadIO m) => m (Accounts store pv) emptyAccounts = do 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, -- 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 store pv m) => + PersistentAccount store (AccountVersionFor pv) -> + Accounts store pv -> + m (Maybe AccountIndex, Accounts store pv) putNewAccount !acct a0@Accounts{..} = do addr <- accountCanonicalAddress acct exists addr a0 >>= \case @@ -290,7 +299,10 @@ putNewAccount !acct a0@Accounts{..} = do 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 :: + (SupportsPersistentAccount store pv m) => + [PersistentAccount store (AccountVersionFor pv)] -> + m (Accounts store pv) fromList accs = do accum <- emptyAccounts foldlM insert accum accs @@ -298,24 +310,28 @@ fromList accs = do 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 :: (SupportsPersistentAccount store pv m) => AccountAddress -> Accounts store 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 -> Accounts pv -> m (Maybe (AccountIndex, PersistentAccount (AccountVersionFor pv))) +getAccountByCredId :: + (SupportsPersistentAccount store pv m) => + ID.RawCredentialRegistrationID -> + Accounts store pv -> + m (Maybe (AccountIndex, PersistentAccount store (AccountVersionFor pv))) getAccountByCredId cid accs@Accounts{..} = Trie.lookup cid accountRegIdHistory >>= \case Nothing -> return Nothing Just ai -> fmap (ai,) <$> indexedAccount ai accs -- | 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', +-- First try lookup in the in-memory difference map associated with the the provided 'Accounts store pv', -- if no account could be looked up, then we fall back to the lmdb backed account map. -- -- If account aliases 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 :: forall store pv m. (SupportsPersistentAccount store pv m) => AccountAddress -> Accounts store pv -> m (Maybe AccountIndex) getAccountIndex addr Accounts{..} = do mAccountDiffMap <- liftIO $ readIORef accountDiffMapRef case mAccountDiffMap of @@ -350,12 +366,12 @@ getAccountIndex addr Accounts{..} = do -- | 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 store pv m) => AccountAddress -> Accounts store pv -> m (Maybe (PersistentAccount store (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 -> Accounts pv -> m (Maybe (AccountIndex, PersistentAccount (AccountVersionFor pv))) +getAccountWithIndex :: forall store pv m. (SupportsPersistentAccount store pv m) => AccountAddress -> Accounts store pv -> m (Maybe (AccountIndex, PersistentAccount store (AccountVersionFor pv))) getAccountWithIndex addr accts = getAccountIndex addr accts >>= \case Nothing -> return Nothing @@ -364,27 +380,44 @@ getAccountWithIndex addr accts = return $ (ai,) <$> mAcc -- | Retrieve the account at a given index. -indexedAccount :: (SupportsPersistentAccount pv m) => AccountIndex -> Accounts pv -> m (Maybe (PersistentAccount (AccountVersionFor pv))) +indexedAccount :: + (SupportsPersistentAccount store pv m) => + AccountIndex -> + Accounts store pv -> + m (Maybe (PersistentAccount store (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 -> Accounts pv -> m (Maybe AccountIndex) +regIdExists :: + (MonadBlobStore m) => + ID.CredentialRegistrationID -> + Accounts (MBSStore m) 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 -> Accounts pv -> m (Accounts pv) +recordRegId :: + (MonadBlobStore m) => + ID.CredentialRegistrationID -> + AccountIndex -> + Accounts (MBSStore m) pv -> + m (Accounts (MBSStore m) pv) recordRegId rid idx accts0 = do accountRegIdHistory' <- Trie.insert (ID.toRawCredRegId rid) idx (accountRegIdHistory accts0) return $! accts0{accountRegIdHistory = accountRegIdHistory'} -recordRegIds :: (MonadBlobStore m) => [(ID.CredentialRegistrationID, AccountIndex)] -> Accounts pv -> m (Accounts pv) +recordRegIds :: + (MonadBlobStore m) => + [(ID.CredentialRegistrationID, AccountIndex)] -> + Accounts (MBSStore m) pv -> + m (Accounts (MBSStore m) 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 -- should generally be avoided if this is not necessary. -loadRegIds :: forall m pv. (MonadBlobStore m) => Accounts pv -> m (Map.Map ID.RawCredentialRegistrationID AccountIndex) +loadRegIds :: forall m pv. (MonadBlobStore m) => Accounts (MBSStore m) pv -> m (Map.Map ID.RawCredentialRegistrationID AccountIndex) loadRegIds accts = Trie.toMap (accountRegIdHistory accts) -- | Perform an update to an account with the given address. @@ -396,13 +429,13 @@ 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 store pv m) => + ( PersistentAccount store (AccountVersionFor pv) -> + m (a, PersistentAccount store (AccountVersionFor pv)) ) -> AccountAddress -> - Accounts pv -> - m (Maybe (AccountIndex, a), Accounts pv) + Accounts store pv -> + m (Maybe (AccountIndex, a), Accounts store pv) updateAccounts fupd addr a0@Accounts{..} = do getAccountIndex addr a0 >>= \case Nothing -> return (Nothing, a0) @@ -415,7 +448,12 @@ updateAccounts fupd addr a0@Accounts{..} = do -- 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 :: + (SupportsPersistentAccount store pv m) => + (PersistentAccount store (AccountVersionFor pv) -> m (a, PersistentAccount store (AccountVersionFor pv))) -> + AccountIndex -> + Accounts store pv -> + m (Maybe a, Accounts store pv) updateAccountsAtIndex fupd ai a0@Accounts{..} = L.update fupd ai accountTable >>= \case Nothing -> return (Nothing, a0) @@ -423,7 +461,12 @@ updateAccountsAtIndex fupd ai a0@Accounts{..} = -- | Set the account at the given index. There must already be an account at the given index. -- (If the account does not exist, this will throw an error.) -setAccountAtIndex :: (SupportsPersistentAccount pv m) => AccountIndex -> PersistentAccount (AccountVersionFor pv) -> Accounts pv -> m (Accounts pv) +setAccountAtIndex :: + (SupportsPersistentAccount store pv m) => + AccountIndex -> + PersistentAccount store (AccountVersionFor pv) -> + Accounts store pv -> + m (Accounts store pv) setAccountAtIndex ai newAcct a0@Accounts{..} = L.update (const (return ((), newAcct))) ai accountTable >>= \case Nothing -> error $ "setAccountAtIndex: no account at index " ++ show ai @@ -433,14 +476,22 @@ setAccountAtIndex ai newAcct a0@Accounts{..} = -- 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 store pv m) => + (PersistentAccount store (AccountVersionFor pv) -> m (PersistentAccount store (AccountVersionFor pv))) -> + AccountIndex -> + Accounts store pv -> + m (Accounts store pv) updateAccountsAtIndex' fupd ai = fmap snd . updateAccountsAtIndex fupd' ai where 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. -allAccounts :: (SupportsPersistentAccount pv m) => Accounts pv -> m [(AccountAddress, AccountIndex)] +allAccounts :: + (SupportsPersistentAccount store pv m) => + Accounts store pv -> + m [(AccountAddress, AccountIndex)] allAccounts accounts = do mDiffMap <- liftIO $ readIORef (accountDiffMapRef accounts) case mDiffMap of @@ -454,21 +505,26 @@ allAccounts accounts = do -- | 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 :: (SupportsPersistentAccount store pv m) => Accounts store pv -> m [AccountAddress] accountAddresses accounts = map fst <$> allAccounts accounts -- | 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 +foldAccounts :: + (SupportsPersistentAccount store pv m) => + (a -> PersistentAccount store (AccountVersionFor pv) -> m a) -> + a -> + Accounts store pv -> + m a foldAccounts f a accts = L.mfold f a (accountTable accts) -- | 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 :: (SupportsPersistentAccount store pv m) => (a -> PersistentAccount store (AccountVersionFor pv) -> m a) -> a -> Accounts store pv -> m a foldAccountsDesc f a accts = L.mfoldDesc f a (accountTable accts) -- | Initialize the LMDB account map if it is not already. -- 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 :: (SupportsPersistentAccount store pv m) => Accounts store pv -> m () tryPopulateLMDBStore accts = do noLMDBAccounts <- LMDBAccountMap.getNumberOfAccounts let expectedSize = L.size $ accountTable accts @@ -495,18 +551,18 @@ tryPopulateLMDBStore accts = do -- | See documentation of @migratePersistentBlockState@. migrateAccounts :: - forall oldpv pv t m. + forall store1 store2 oldpv pv t m. ( IsProtocolVersion oldpv, IsProtocolVersion pv, SupportMigration m t, - SupportsPersistentAccount oldpv m, - SupportsPersistentAccount pv (t m), + SupportsPersistentAccount store1 oldpv m, + SupportsPersistentAccount store2 pv (t m), AccountsMigration (AccountVersionFor pv) (t m), MonadLogger (t m) ) => StateMigrationParameters oldpv pv -> - Accounts oldpv -> - t m (Accounts pv) + Accounts store1 oldpv -> + t m (Accounts store2 pv) migrateAccounts migration Accounts{..} = do logEvent GlobalState LLTrace "Migrating accounts" let migrateAccount acct = do diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlobStore.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlobStore.hs index b01095a17e..ffcb13d87f 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlobStore.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlobStore.hs @@ -43,6 +43,7 @@ module Concordium.GlobalState.Persistent.BlobStore ( truncateBlobStore, isValidBlobRef, BlobPtr (..), + MBSStore, MonadBlobStore (..), BlobStoreT (..), alterBlobStoreT, @@ -174,12 +175,12 @@ import qualified Concordium.Crypto.SHA256 as H import qualified Concordium.GlobalState.AccountMap.LMDB as LMDBAccountMap import Concordium.Types.HashableTo --- | A @BlobRef a@ represents an offset on a file, at +-- | A @BlobRef store a@ represents an offset on a file, at -- which a value of type @a@ is stored. -newtype BlobRef a = BlobRef {theBlobRef :: Word64} +newtype BlobRef store a = BlobRef {theBlobRef :: Word64} deriving (Eq, Ord, Serialize) -instance Show (BlobRef a) where +instance Show (BlobRef store a) where show (BlobRef v) = '@' : show v -- | The handler for the BlobStore file @@ -193,7 +194,7 @@ data BlobHandle = BlobHandle } -- | The storage context -data BlobStoreAccess = BlobStoreAccess +data BlobStoreAccess store = BlobStoreAccess { blobStoreFile :: !(MVar BlobHandle), blobStoreFilePath :: !FilePath, -- | The blob store file memory-mapped into a (read-only) 'ByteString'. @@ -203,32 +204,32 @@ data BlobStoreAccess = BlobStoreAccess } -- | Context needed to operate on the blob store. -data BlobStore = BlobStore +data BlobStore store = BlobStore { -- | A handle to the underlying storage. - bscBlobStore :: !BlobStoreAccess, + bscBlobStore :: !(BlobStoreAccess store), -- | Callbacks for loading parts of the state. This is needed by V1 contract -- state implementation. - bscLoadCallback :: !LoadCallback, + bscLoadCallback :: !(LoadCallback store), -- | Callbacks for storing new state. This is needed by V1 contract state -- implementation. - bscStoreCallback :: !StoreCallback + bscStoreCallback :: !(StoreCallback store) } -class HasBlobStore a where +class HasBlobStore store a | a -> store where -- | A handle to access the underlying storage. - blobStore :: a -> BlobStoreAccess + blobStore :: a -> BlobStoreAccess store -- | Callbacks for loading parts of the state. This is needed by V1 contract -- state implementation, but should otherwise not be used by Haskell code directly. - blobLoadCallback :: a -> LoadCallback + blobLoadCallback :: a -> LoadCallback store -- | Callbacks for storing new state. This is needed by V1 contract state -- implementation, but should otherwise not be used by Haskell code directly. - blobStoreCallback :: a -> StoreCallback + blobStoreCallback :: a -> StoreCallback store -- | Construct callbacks for accessing the blob store. -- These callbacks must be freed in order that memory is not leaked. -mkCallbacksFromBlobStore :: BlobStoreAccess -> IO (LoadCallback, StoreCallback) +mkCallbacksFromBlobStore :: BlobStoreAccess store -> IO (LoadCallback store, StoreCallback store) mkCallbacksFromBlobStore bstore = do storeCallback <- createStoreCallback (\ptr size -> theBlobRef <$> (writeBlobBS bstore =<< BSUnsafe.unsafePackCStringLen (castPtr ptr, fromIntegral size))) loadCallback <- createLoadCallback $ \location -> do @@ -239,14 +240,14 @@ mkCallbacksFromBlobStore bstore = do -- | Free callbacks constructed with 'mkCallbacksFromBlobStore'. This can only be -- called once for each constructed callback. -freeCallbacks :: LoadCallback -> StoreCallback -> IO () +freeCallbacks :: LoadCallback store -> StoreCallback store -> IO () freeCallbacks fp1 fp2 = do freeHaskellFunPtr fp1 freeHaskellFunPtr fp2 -- | Create a new blob store at a given location. -- Fails if a file or directory at that location already exists. -createBlobStore :: FilePath -> IO BlobStore +createBlobStore :: FilePath -> IO (BlobStore store) createBlobStore blobStoreFilePath = do pathEx <- doesPathExist blobStoreFilePath when pathEx $ throwIO (userError $ "Blob store path already exists: " ++ blobStoreFilePath) @@ -258,8 +259,8 @@ createBlobStore blobStoreFilePath = do return BlobStore{..} -- | Load an existing blob store from a file. --- The file must be readable and writable, but this is not checked here. -loadBlobStore :: FilePath -> IO BlobStore +-- The file must be readable and writeable, but this is not checked here. +loadBlobStore :: FilePath -> IO (BlobStore store) loadBlobStore blobStoreFilePath = do bhHandle <- openBinaryFile blobStoreFilePath ReadWriteMode bhSize <- fromIntegral <$> hFileSize bhHandle @@ -271,13 +272,13 @@ loadBlobStore blobStoreFilePath = do -- | Flush all buffers associated with the blob store, -- ensuring all the contents is written out. -flushBlobStore :: BlobStoreAccess -> IO () +flushBlobStore :: BlobStoreAccess store -> IO () flushBlobStore BlobStoreAccess{..} = withMVar blobStoreFile (hFlush . bhHandle) -- | Close all references to the blob store, flushing it -- in the process. -closeBlobStore :: BlobStore -> IO () +closeBlobStore :: BlobStore store -> IO () closeBlobStore BlobStore{..} = do BlobHandle{..} <- takeMVar (blobStoreFile bscBlobStore) writeIORef (blobStoreMMap bscBlobStore) BS.empty @@ -285,7 +286,7 @@ closeBlobStore BlobStore{..} = do freeCallbacks bscLoadCallback bscStoreCallback -- | Close all references to the blob store and delete the backing file. -destroyBlobStore :: BlobStore -> IO () +destroyBlobStore :: BlobStore store -> IO () destroyBlobStore bs@BlobStore{..} = do closeBlobStore bs performGC @@ -298,7 +299,7 @@ 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 :: forall m a. (MonadIO m, MonadCatch.MonadMask m) => FilePath -> BlobStoreT BlobStore m a -> m a +runBlobStoreTemp :: forall m store a. (MonadIO m, MonadCatch.MonadMask m) => FilePath -> BlobStoreT store (BlobStore store) m a -> m a runBlobStoreTemp dir a = MonadCatch.bracket openf closef usef where openf = liftIO $ openBinaryTempFile dir "blb.dat" @@ -330,7 +331,7 @@ runBlobStoreTemp dir a = MonadCatch.bracket openf closef usef -- the current 'blobStoreMMap' is the only mapping of the file (which can be relied on if no writes -- have occurred). Since the existing memory map is invalidated, any other references to it will -- also be invalidated, such as 'BS.ByteString's returned by 'loadBlobPtr'. -truncateBlobStore :: BlobStoreAccess -> BlobRef a -> IO () +truncateBlobStore :: BlobStoreAccess store -> BlobRef store a -> IO () truncateBlobStore BlobStoreAccess{..} (BlobRef offset) = do bh@BlobHandle{..} <- takeMVar blobStoreFile eres <- try $ do @@ -361,7 +362,7 @@ truncateBlobStore BlobStoreAccess{..} (BlobRef offset) = do Right () -> return () -- | Read a bytestring from the blob store at the given offset using the file handle. -readBlobBSFromHandle :: BlobStoreAccess -> BlobRef a -> IO BS.ByteString +readBlobBSFromHandle :: BlobStoreAccess store -> BlobRef store a -> IO BS.ByteString readBlobBSFromHandle BlobStoreAccess{..} (BlobRef offset) = mask $ \restore -> do bh@BlobHandle{..} <- takeMVar blobStoreFile eres <- try $ restore $ do @@ -386,7 +387,7 @@ readBlobBSFromHandle BlobStoreAccess{..} (BlobRef offset) = mask $ \restore -> d Right bs -> return bs -- | Determine the length of the blob store file using the file handle. -blobBSFileLength :: BlobStoreAccess -> IO Integer +blobBSFileLength :: BlobStoreAccess store -> IO Integer blobBSFileLength BlobStoreAccess{..} = mask $ \restore -> do bh@BlobHandle{..} <- takeMVar blobStoreFile eres <- try $ restore $ do @@ -400,7 +401,7 @@ blobBSFileLength BlobStoreAccess{..} = mask $ \restore -> do -- | Read a bytestring from the blob store at the given offset using the memory map. -- The file handle is used as a backstop if the data to be read would be outside the memory map -- even after re-mapping. -readBlobBS :: BlobStoreAccess -> BlobRef a -> IO BS.ByteString +readBlobBS :: BlobStoreAccess store -> BlobRef store a -> IO BS.ByteString readBlobBS bs@BlobStoreAccess{..} br@(BlobRef offset) = do let ioffset = fromIntegral offset when (ioffset < 0) $ throwIO $ userError "Attempted to read an invalid BlobRef" @@ -445,11 +446,11 @@ readBlobBS bs@BlobStoreAccess{..} br@(BlobRef offset) = do -- least on some platforms the blob store sometimes ends up with enough trailing -- zeros that the first check above succeeds, but those zeros are not valid -- data. This happens if the node is killed at the right time. -isValidBlobRef :: (MonadCatch.MonadCatch m, BlobStorable m a) => BlobRef a -> m Bool +isValidBlobRef :: (MonadCatch.MonadCatch m, BlobStorable m a) => BlobRef (MBSStore m) a -> m Bool isValidBlobRef br = (True <$ loadRef br) `MonadCatch.catch` (\(_ :: SomeException) -> return False) -- | Write a bytestring into the blob store and return the offset -writeBlobBS :: BlobStoreAccess -> BS.ByteString -> IO (BlobRef a) +writeBlobBS :: BlobStoreAccess store -> BS.ByteString -> IO (BlobRef store a) writeBlobBS BlobStoreAccess{..} bs = mask $ \restore -> do bh@BlobHandle{bhHandle = writeHandle, bhAtEnd = atEnd} <- takeMVar blobStoreFile eres <- try $ restore $ do @@ -475,7 +476,7 @@ writeBlobBS BlobStoreAccess{..} bs = mask $ \restore -> do -- -- This is used for providing the Rust side with raw bytes of an 'Artifact' without having to -- deserialize it beforehand. -data BlobPtr a = BlobPtr +data BlobPtr store a = BlobPtr { -- | The offset of @a@ in the 'BlobStore'. theBlobPtr :: !Word64, -- | The length to read from the offset. @@ -484,7 +485,7 @@ data BlobPtr a = BlobPtr deriving (Eq, Show) -- | Read a bytestring from the blob store at the given offset and length using the file handle. -readBlobPtrBSFromHandle :: BlobStoreAccess -> BlobPtr a -> IO BS.ByteString +readBlobPtrBSFromHandle :: BlobStoreAccess store -> BlobPtr store a -> IO BS.ByteString readBlobPtrBSFromHandle BlobStoreAccess{..} BlobPtr{..} = mask $ \restore -> do bh@BlobHandle{..} <- takeMVar blobStoreFile eres <- try $ restore $ do @@ -498,7 +499,7 @@ readBlobPtrBSFromHandle BlobStoreAccess{..} BlobPtr{..} = mask $ \restore -> do -- | Read a bytestring from the blob store at the given offset and length using the memory map. -- The file handle is used as a backstop if the data to be read would be outside the memory map -- even after re-mapping. -readBlobPtrBS :: BlobStoreAccess -> BlobPtr a -> IO BS.ByteString +readBlobPtrBS :: BlobStoreAccess store -> BlobPtr store a -> IO BS.ByteString readBlobPtrBS bs@BlobStoreAccess{..} bptr@BlobPtr{..} = do let ptrEnd = fromIntegral $ theBlobPtr + blobPtrLen mmap0 <- readIORef blobStoreMMap @@ -515,6 +516,9 @@ readBlobPtrBS bs@BlobStoreAccess{..} bptr@BlobPtr{..} = do then readBlobPtrBSFromHandle bs bptr else return $! BS.take (fromIntegral blobPtrLen) (BS.drop (fromIntegral theBlobPtr) mmap) +-- | The associated store type for a monad. +type family MBSStore (m :: Type -> Type) + -- | Typeclass for a monad to be equipped with a blob store. -- This allows a 'BS.ByteString' to be written to the store, -- obtaining a 'BlobRef', and a 'BlobRef' to be read back as @@ -525,15 +529,15 @@ readBlobPtrBS bs@BlobStoreAccess{..} bptr@BlobPtr{..} = do -- that can be projected to a 'BlobStore' (@HasBlobStore r@). class (MonadIO m) => MonadBlobStore m where -- | Store a 'BS.ByteString' and return a reference to it. - storeRaw :: BS.ByteString -> m (BlobRef a) - default storeRaw :: (MonadReader r m, HasBlobStore r) => BS.ByteString -> m (BlobRef a) + storeRaw :: BS.ByteString -> m (BlobRef (MBSStore m) a) + default storeRaw :: (MonadReader r m, HasBlobStore (MBSStore m) r) => BS.ByteString -> m (BlobRef (MBSStore m) a) storeRaw b = do bs <- blobStore <$> ask liftIO $ writeBlobBS bs b -- | Load a 'BS.ByteString' from a reference. - loadRaw :: BlobRef a -> m BS.ByteString - default loadRaw :: (MonadReader r m, HasBlobStore r) => BlobRef a -> m BS.ByteString + loadRaw :: BlobRef (MBSStore m) a -> m BS.ByteString + default loadRaw :: (MonadReader r m, HasBlobStore (MBSStore m) r) => BlobRef (MBSStore m) a -> m BS.ByteString loadRaw r = do bs <- blobStore <$> ask liftIO $ readBlobBS bs r @@ -543,29 +547,29 @@ class (MonadIO m) => MonadBlobStore m where -- should be reliably written, and available if the file is -- subsequently loaded. flushStore :: m () - default flushStore :: (MonadReader r m, HasBlobStore r) => m () + default flushStore :: (MonadReader r m, HasBlobStore (MBSStore m) r) => m () flushStore = do bs <- blobStore <$> ask liftIO $ flushBlobStore bs -- | Get callbacks that can be given to foreign code (i.e., passed via FFI) -- to access the blob store. - getCallbacks :: m (LoadCallback, StoreCallback) - default getCallbacks :: (MonadReader r m, HasBlobStore r) => m (LoadCallback, StoreCallback) + getCallbacks :: m (LoadCallback store, StoreCallback store) + default getCallbacks :: (MonadReader r m, HasBlobStore (MBSStore m) r) => m (LoadCallback store, StoreCallback store) getCallbacks = do r <- ask return (blobLoadCallback r, blobStoreCallback r) -- | Access a blob pointer directly. The function should ONLY READ the memory at the pointer, -- and not read beyond the length of the 'BlobPtr'. - withBlobPtr :: BlobPtr a -> (Ptr a -> IO b) -> m b + withBlobPtr :: BlobPtr (MBSStore m) a -> (Ptr a -> IO b) -> m b withBlobPtr bptr f = do bytes <- loadBlobPtr bptr liftIO $ BSUnsafe.unsafeUseAsCString bytes (f . castPtr) -- | Access a blob pointer directly as a 'BS.ByteString'. - loadBlobPtr :: BlobPtr a -> m BS.ByteString - default loadBlobPtr :: (MonadReader r m, HasBlobStore r) => BlobPtr a -> m BS.ByteString + loadBlobPtr :: BlobPtr (MBSStore m) a -> m BS.ByteString + default loadBlobPtr :: (MonadReader r m, HasBlobStore (MBSStore m) r) => BlobPtr (MBSStore m) a -> m BS.ByteString loadBlobPtr bptr = do bs <- blobStore <$> ask liftIO $ readBlobPtrBS bs bptr @@ -574,7 +578,7 @@ class (MonadIO m) => MonadBlobStore m where {-# INLINE loadRaw #-} {-# INLINE flushStore #-} -instance HasBlobStore BlobStore where +instance HasBlobStore store (BlobStore store) where blobStore = bscBlobStore blobLoadCallback = bscLoadCallback blobStoreCallback = bscStoreCallback @@ -587,7 +591,7 @@ type SupportMigration m t = (MonadBlobStore m, MonadTrans t, MonadBlobStore (t m -- | A monad transformer that is equivalent to 'ReaderT' but provides a 'MonadBlobStore' instance -- based on the context (rather than lifting). -newtype BlobStoreT (r :: Type) (m :: Type -> Type) (a :: Type) = BlobStoreT {runBlobStoreT :: r -> m a} +newtype BlobStoreT store (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, MonadCatch.MonadMask) via (ReaderT r m) @@ -595,28 +599,30 @@ newtype BlobStoreT (r :: Type) (m :: Type -> Type) (a :: Type) = BlobStoreT {run (MonadTrans) via (ReaderT r) -instance (HasBlobStore r, MonadIO m) => MonadBlobStore (BlobStoreT r m) +type instance MBSStore (BlobStoreT store r m) = store + +instance (HasBlobStore store r, MonadIO m) => MonadBlobStore (BlobStoreT store r m) deriving via - (LMDBAccountMap.AccountMapStoreMonad (BlobStoreT r m)) + (LMDBAccountMap.AccountMapStoreMonad (BlobStoreT store r m)) instance (MonadIO m, MonadLogger m, LMDBAccountMap.HasDatabaseHandlers r) => - LMDBAccountMap.MonadAccountMapStore (BlobStoreT r m) + LMDBAccountMap.MonadAccountMapStore (BlobStoreT store 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 +alterBlobStoreT :: (r1 -> r2) -> BlobStoreT store r2 m a -> BlobStoreT store r1 m a alterBlobStoreT f (BlobStoreT a) = BlobStoreT (a . f) -- | A simple monad implementing 'MonadBlobStore' that is equivalent to -- @ReaderT r IO@. -type BlobStoreM' r = BlobStoreT r IO +type BlobStoreM' store r = BlobStoreT store r IO -- | A simple monad implementing 'MonadBlobStore' that is equivalent to -- @ReaderT BlobStore IO@. -type BlobStoreM = BlobStoreM' BlobStore +type BlobStoreM store = BlobStoreM' store (BlobStore store) -- | Run a 'BlobStoreM'' operation with the supplied context. -runBlobStoreM :: BlobStoreM' r a -> r -> IO a +runBlobStoreM :: BlobStoreM' store r a -> r -> IO a runBlobStoreM = runBlobStoreT -- | A wrapper type for lifting 'MonadBlobStore' instances over monad transformers. @@ -625,6 +631,8 @@ runBlobStoreM = runBlobStoreT newtype LiftMonadBlobStore (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) (a :: Type) = LiftMonadBlobStore (t m a) deriving (MonadTrans, Functor, Applicative, Monad, MonadIO) +type instance MBSStore (LiftMonadBlobStore t m) = MBSStore m + instance (MonadTrans t, MonadBlobStore m, MonadIO (t m)) => MonadBlobStore (LiftMonadBlobStore t m) where storeRaw = lift . storeRaw {-# INLINE storeRaw #-} @@ -639,21 +647,26 @@ instance (MonadTrans t, MonadBlobStore m, MonadIO (t m)) => MonadBlobStore (Lift loadBlobPtr = lift . loadBlobPtr {-# INLINE loadBlobPtr #-} +type instance MBSStore (WriterT w m) = MBSStore m deriving via (LiftMonadBlobStore (WriterT w) m) instance (Monoid w, MonadBlobStore m) => MonadBlobStore (WriterT w m) +type instance MBSStore (StateT s m) = MBSStore m deriving via (LiftMonadBlobStore (StateT s) m) instance (MonadBlobStore m) => MonadBlobStore (StateT s m) +type instance MBSStore (ExceptT e m) = MBSStore m deriving via (LiftMonadBlobStore (ExceptT e) m) instance (MonadBlobStore m) => MonadBlobStore (ExceptT e m) +type instance MBSStore (ReaderT r m) = MBSStore m + -- | This instance lifts a 'MonadBlobStore' over a 'ReaderT' transformer. -- This is used to implement a 'Cacheable' instance for the persistent -- 'Concordium.GlobalState.Persistent.Instances' type, which requires @@ -668,7 +681,7 @@ deriving via -- | An in-memory blob store. This is intended for testing purposes, as it can be more convenient -- than working with files. Internally, the blob store is handled as a lazy 'LBS.ByteString' guarded -- by an 'MVar'. -data MemBlobStore = MemBlobStore +data MemBlobStore store = MemBlobStore { -- | 'MVar' containing the entire blob store as a lazy 'LBS.ByteString'. -- This is accessed by 'readMVar' for readers, and 'takeMVar'/'putMVar' for writers. -- This means that writers may block concurrent readers and writers, but readers will not block @@ -677,16 +690,16 @@ data MemBlobStore = MemBlobStore -- | 'MVar' containing the callbacks. This is initially empty, and the callbacks are created -- only when first required. After this has been set, it should only become empty again when -- the 'MemBlobStore' is to be disposed of. - mbsCallbacks :: !(MVar (LoadCallback, StoreCallback)) + mbsCallbacks :: !(MVar (LoadCallback store, StoreCallback store)) } -- | Create a fresh, empty 'MemBlobStore'. -newMemBlobStore :: IO MemBlobStore +newMemBlobStore :: IO (MemBlobStore store) newMemBlobStore = MemBlobStore <$> newMVar LBS.empty <*> newEmptyMVar -- | Destroy a 'MemBlobStore'. The caller should ensure that no operations on the 'MemBlobStore' -- can happen after the call to 'destroyMemBlobStore'. -destroyMemBlobStore :: MemBlobStore -> IO () +destroyMemBlobStore :: MemBlobStore store -> IO () destroyMemBlobStore MemBlobStore{..} = do _ <- takeMVar theMemBlobStore mcbks <- tryTakeMVar mbsCallbacks @@ -713,7 +726,7 @@ loadMem mv offset = do Right len -> return $! LBS.toStrict (LBS.take (fromIntegral len) (LBS.drop 8 bs')) -- | Get the callbacks for a 'MemBlobStore'. -getMemCallbacks :: MemBlobStore -> IO (LoadCallback, StoreCallback) +getMemCallbacks :: MemBlobStore store -> IO (LoadCallback store, StoreCallback store) getMemCallbacks mbs@MemBlobStore{..} = tryReadMVar mbsCallbacks >>= \case Just cbs -> return cbs @@ -736,15 +749,15 @@ getMemCallbacks mbs@MemBlobStore{..} = getMemCallbacks mbs -- | A monad transformer that provides an instance of 'MonadBlobStore' based on a 'MemBlobStore'. -newtype MemBlobStoreT (m :: (Type -> Type)) (a :: Type) = MemBlobStoreT {runMemBlobStoreT :: MemBlobStore -> m a} +newtype MemBlobStoreT store (m :: (Type -> Type)) (a :: Type) = MemBlobStoreT {runMemBlobStoreT :: MemBlobStore store -> m a} deriving - (Functor, Applicative, Monad, MonadReader MemBlobStore, MonadIO, MonadFail, MonadLogger, MonadCatch.MonadThrow, MonadCatch.MonadCatch) - via (ReaderT MemBlobStore m) + (Functor, Applicative, Monad, MonadReader (MemBlobStore store), MonadIO, MonadFail, MonadLogger, MonadCatch.MonadThrow, MonadCatch.MonadCatch) + via (ReaderT (MemBlobStore store) m) deriving (MonadTrans) - via (ReaderT MemBlobStore) + via (ReaderT (MemBlobStore store)) -instance (MonadIO m) => MonadBlobStore (MemBlobStoreT m) where +instance (MonadIO m) => MonadBlobStore (MemBlobStoreT store m) where storeRaw b = do mv <- asks theMemBlobStore liftIO $ BlobRef <$> storeMem mv b @@ -823,7 +836,7 @@ class (MonadBlobStore m) => BlobStorable m a where {-# INLINE storeUpdate #-} -- | Store a value in the blob store and return a reference to it. -storeRef :: (BlobStorable m a) => a -> m (BlobRef a) +storeRef :: (BlobStorable m a) => a -> m (BlobRef (MBSStore m) a) storeRef v = do p <- runPut . fst <$> storeUpdate v storeRaw p @@ -831,14 +844,14 @@ storeRef v = do -- | Store a value in the blob store, returning a reference to it and -- an updated value. (See 'storeUpdate'.) -storeUpdateRef :: (BlobStorable m a) => a -> m (BlobRef a, a) +storeUpdateRef :: (BlobStorable m a) => a -> m (BlobRef (MBSStore m) a, a) storeUpdateRef v = do (!p, !v') <- storeUpdate v (,v') <$> storeRaw (runPut p) {-# INLINE storeUpdateRef #-} -- | Load a value from a reference. -loadRef :: (BlobStorable m a) => BlobRef a -> m a +loadRef :: (BlobStorable m a) => BlobRef (MBSStore m) a -> m a loadRef ref = do bs <- loadRaw ref case runGet load bs of @@ -863,10 +876,10 @@ loadRef ref = do -- * 'loadDirect' is functionally equivalent to 'loadRef'. class (MonadBlobStore m) => DirectBlobStorable m a where -- | Store a value of type @a@, possibly updating its representation. - storeUpdateDirect :: a -> m (BlobRef a, a) + storeUpdateDirect :: a -> m (BlobRef (MBSStore m) a, a) -- | Load a value of type @a@ from the underlying storage. - loadDirect :: BlobRef a -> m a + loadDirect :: BlobRef (MBSStore m) a -> m a instance {-# OVERLAPPABLE #-} (MonadBlobStore m, BlobStorable m a) => DirectBlobStorable m a where storeUpdateDirect = storeUpdateRef @@ -904,7 +917,7 @@ class HasNull ref where isNotNull :: ref -> Bool isNotNull = not . isNull -instance HasNull (BlobRef a) where +instance HasNull (BlobRef store a) where refNull = BlobRef maxBound isNull = (== refNull) @@ -924,9 +937,9 @@ instance (HasNull ref, Serialize ref) => Serialize (Nullable ref) where r <- get return $! if isNull r then Null else Some r -instance (MonadBlobStore m) => BlobStorable m (Nullable (BlobRef a)) +instance (MonadBlobStore m) => BlobStorable m (Nullable (BlobRef store a)) -instance (MonadBlobStore m) => BlobStorable m (BlobRef a) +instance (MonadBlobStore m) => BlobStorable m (BlobRef store a) -- This instance has to follow the instance for HashableTo H.Hash (Maybe v), see -- Concordium.Types.HashableTo @@ -939,9 +952,9 @@ instance (MHashableTo m H.Hash v) => MHashableTo m H.Hash (Nullable v) where -- | An instance @Reference m ref a@ specifies how a value of type @a@ can be stored and retrieved over a reference type -- @ref@ in the monad @m@. The constraints on this typeclass are specially permissive and it is responsibility of the -- instances to refine those. This typeclass is specifically designed to be used by BufferedRef and HashedBufferedRef. -class (Monad m) => Reference m ref a where +class (Monad m) => Reference m store ref a | ref -> store where -- | Given a reference, write it to the disk and return the updated reference and the generated offset in the store - refFlush :: ref a -> m (ref a, BlobRef a) + refFlush :: ref a -> m (ref a, BlobRef store a) -- | Given a reference, read the value and return the possibly updated reference (that now holds the value in memory) refCache :: ref a -> m (a, ref a) @@ -975,8 +988,8 @@ class (Monad m) => Reference m ref a where -- to a disk value. But this may be different for some references such as -- 'CachedRef'. migrateReference :: - forall t m ref1 ref2 a b. - (MonadTrans t, Reference m ref1 a, Reference (t m) ref2 b) => + forall t m store1 store2 ref1 ref2 a b. + (MonadTrans t, Reference m store1 ref1 a, Reference (t m) store2 ref2 b) => (a -> t m b) -> ref1 a -> t m (ref2 b) @@ -1016,37 +1029,37 @@ migrateReference f hb = do -- -- The choice to have 'BRBoth' at all (and not just use 'BRMemory') was to reduce the indirection -- for the common case where the data is both in memory and on disk. -data BufferedRef a +data BufferedRef store a = -- | Value stored on disk - BRBlobbed {brRef :: !(BlobRef a)} + BRBlobbed {brRef :: !(BlobRef store a)} | -- | Value stored in memory and possibly on disk. -- 'brIORef' contains 'Null' if the value has never been written to the blob store, and -- otherwise @Some BRBoth{..}@ with the reference and updated value. - BRMemory {brIORef :: !(IORef (Nullable (BufferedRef a))), brValue :: !a} + BRMemory {brIORef :: !(IORef (Nullable (BufferedRef store a))), brValue :: !a} | -- | Value stored in memory and on disk. - BRBoth {brRef :: !(BlobRef a), brValue :: !a} + BRBoth {brRef :: !(BlobRef store a), brValue :: !a} -- | Create a @BRMemory@ value with a null reference (so the value is just in memory) -makeBufferedRef :: (MonadIO m) => a -> m (BufferedRef a) +makeBufferedRef :: (MonadIO m) => a -> m (BufferedRef store a) makeBufferedRef v = liftIO $ do ref <- newIORef Null return $ BRMemory ref v -- | Create a 'BufferedRef' from a 'BlobRef', without loading anything. -blobRefToBufferedRef :: BlobRef a -> BufferedRef a +blobRefToBufferedRef :: BlobRef store a -> BufferedRef store a blobRefToBufferedRef = BRBlobbed -instance (Show a) => Show (BufferedRef a) where +instance (Show a) => Show (BufferedRef store a) where show (BRBlobbed r) = show r show (BRMemory _ v) = "{" ++ show v ++ "}" show (BRBoth r v) = "{" ++ show v ++ "}@" ++ show r -instance (DirectBlobStorable m a) => BlobStorable m (BufferedRef a) where +instance (DirectBlobStorable m a, store ~ MBSStore m) => BlobStorable m (BufferedRef store a) where load = fmap BRBlobbed <$> load storeUpdate (BRMemory ref v) = liftIO (readIORef ref) >>= \case Null -> do - (r' :: BlobRef a, v') <- storeUpdateDirect v + (r' :: BlobRef store a, v') <- storeUpdateDirect v let br' = BRBoth r' v' liftIO . writeIORef ref $! Some br' return (put r', br') @@ -1056,45 +1069,45 @@ instance (DirectBlobStorable m a) => BlobStorable m (BufferedRef a) where return (put ref, x) -- | Stores in-memory data to disk if it has not been stored yet and returns pointer to saved data -getBRRef :: (DirectBlobStorable m a) => BufferedRef a -> m (BlobRef a) +getBRRef :: (DirectBlobStorable m a) => BufferedRef (MBSStore m) a -> m (BlobRef (MBSStore m) a) getBRRef (BRMemory ref v) = liftIO (readIORef ref) >>= \case Null -> do - (r' :: BlobRef a, v') <- storeUpdateDirect v + (r' :: BlobRef store a, v') <- storeUpdateDirect v liftIO . writeIORef ref $! Some (BRBoth r' v') return r' Some br' -> getBRRef br' getBRRef (BRBoth r _) = return r getBRRef (BRBlobbed r) = return r -instance (DirectBlobStorable m a) => BlobStorable m (Nullable (BufferedRef a)) where +instance (DirectBlobStorable m a, store ~ MBSStore m) => BlobStorable m (Nullable (BufferedRef store a)) where load = do - (r :: BlobRef a) <- get + (r :: BlobRef store a) <- get if isNull r then return (pure Null) else return $ pure $ Some $ BRBlobbed r - storeUpdate n@Null = return (put (refNull :: BlobRef a), n) + storeUpdate n@Null = return (put (refNull :: BlobRef store a), n) storeUpdate (Some v) = do (!r, !v') <- storeUpdate v return (r, Some v') -- | Load the value from a @BufferedRef@ not caching it. -loadBufferedRef :: (DirectBlobStorable m a) => BufferedRef a -> m a +loadBufferedRef :: (DirectBlobStorable m a) => BufferedRef (MBSStore m) a -> m a loadBufferedRef = refLoad -- | Load a 'BufferedRef' and cache it if it wasn't already in memory. -cacheBufferedRef :: (DirectBlobStorable m a) => BufferedRef a -> m (a, BufferedRef a) +cacheBufferedRef :: (DirectBlobStorable m a) => BufferedRef (MBSStore m) a -> m (a, BufferedRef (MBSStore m) a) cacheBufferedRef = refCache -- | If given a Blobbed reference, do nothing. Otherwise if needed store the value. -flushBufferedRef :: (DirectBlobStorable m a) => BufferedRef a -> m (BufferedRef a, BlobRef a) +flushBufferedRef :: (DirectBlobStorable m a) => BufferedRef (MBSStore m) a -> m (BufferedRef (MBSStore m) a, BlobRef (MBSStore m) a) flushBufferedRef = refFlush -- | Convert a Cached reference into a Blobbed one storing the data if needed. -uncacheBufferedRef :: (DirectBlobStorable m a) => BufferedRef a -> m (BufferedRef a) +uncacheBufferedRef :: (DirectBlobStorable m a) => BufferedRef (MBSStore m) a -> m (BufferedRef (MBSStore m) a) uncacheBufferedRef = refUncache -instance (DirectBlobStorable m a) => Reference m BufferedRef a where +instance (DirectBlobStorable m a, store ~ MBSStore m) => Reference m store (BufferedRef store) a where refMake = makeBufferedRef refLoad (BRBlobbed ref) = loadDirect ref @@ -1110,7 +1123,7 @@ instance (DirectBlobStorable m a) => Reference m BufferedRef a where refFlush (BRMemory ref v) = liftIO (readIORef ref) >>= \case Null -> do - (!r' :: BlobRef a, !v') <- storeUpdateDirect v + (!r' :: BlobRef store a, !v') <- storeUpdateDirect v let br' = BRBoth r' v' liftIO . writeIORef ref $! Some br' return (br', r') @@ -1126,12 +1139,12 @@ instance (DirectBlobStorable m a) => Reference m BufferedRef a where {-# INLINE refCache #-} {-# INLINE refUncache #-} -instance (DirectBlobStorable m a, MHashableTo m h a) => MHashableTo m h (BufferedRef a) where +instance (DirectBlobStorable m a, MHashableTo m h a, store ~ MBSStore m) => MHashableTo m h (BufferedRef store a) where getHashM ref = getHashM =<< refLoad ref -instance (DirectBlobStorable m a, BlobStorable m b) => BlobStorable m (Nullable (BufferedRef a, b)) where +instance (DirectBlobStorable m a, BlobStorable m b, store ~ MBSStore m) => BlobStorable m (Nullable (BufferedRef store a, b)) where load = do - (r :: BlobRef a) <- get + (r :: BlobRef store a) <- get if isNull r then return (pure Null) else do @@ -1139,14 +1152,14 @@ instance (DirectBlobStorable m a, BlobStorable m b) => BlobStorable m (Nullable return $ do binner <- bval pure $ Some (BRBlobbed r, binner) - storeUpdate n@Null = return (put (refNull :: BlobRef a), n) + storeUpdate n@Null = return (put (refNull :: BlobRef store a), n) storeUpdate (Some v) = do (!r, !v') <- storeUpdate v return (r, Some v') -instance (DirectBlobStorable m a, BlobStorable m b) => BlobStorable m (Nullable (HashedBufferedRef a, b)) where +instance (DirectBlobStorable m a, BlobStorable m b, store ~ MBSStore m) => BlobStorable m (Nullable (HashedBufferedRef store a, b)) where load = do - (r :: BlobRef a) <- get + (r :: BlobRef store a) <- get if isNull r then return (pure Null) else do @@ -1155,7 +1168,7 @@ instance (DirectBlobStorable m a, BlobStorable m b) => BlobStorable m (Nullable binner <- bval hshRef <- liftIO $ newIORef Null pure $ Some (HashedBufferedRef (BRBlobbed r) hshRef, binner) - storeUpdate n@Null = return (put (refNull :: BlobRef a), n) + storeUpdate n@Null = return (put (refNull :: BlobRef store a), n) storeUpdate (Some v) = do (!r, !v') <- storeUpdate v return (r, Some v') @@ -1163,20 +1176,20 @@ instance (DirectBlobStorable m a, BlobStorable m b) => BlobStorable m (Nullable -- | A value that always exists in memory but may also exist on disk. -- The disk reference is shared via an 'IORef', which ensures that copies created before -- the value is flushed to disk will share the same underlying reference. -data EagerBufferedRef a = EagerBufferedRef - { ebrIORef :: !(IORef (BlobRef a)), +data EagerBufferedRef store a = EagerBufferedRef + { ebrIORef :: !(IORef (BlobRef store a)), ebrValue :: !a } -- | Directly get the value in an 'EagerBufferedRef'. -eagerBufferedDeref :: EagerBufferedRef a -> a +eagerBufferedDeref :: EagerBufferedRef store a -> a {-# INLINE eagerBufferedDeref #-} eagerBufferedDeref = ebrValue -- | Make an 'EagerBufferedRef' from a 'BufferedRef'. -- Note: if the 'BufferedRef' is not already flushed to the disk, then the association between the -- old and new reference is lost, so they will not share the same underlying 'BlobRef' once flushed. -eagerBufferedRefFromBufferedRef :: (DirectBlobStorable m a) => BufferedRef a -> m (EagerBufferedRef a) +eagerBufferedRefFromBufferedRef :: (DirectBlobStorable m a) => BufferedRef (MBSStore m) a -> m (EagerBufferedRef (MBSStore m) a) eagerBufferedRefFromBufferedRef (BRBlobbed r) = do v <- loadDirect r makeEagerBufferedRef r v @@ -1191,29 +1204,29 @@ eagerBufferedRefFromBufferedRef (BRBoth r v) = makeEagerBufferedRef r v migrateEagerBufferedRef :: (BlobStorable m a, BlobStorable (t m) b, MonadTrans t) => (a -> t m b) -> - EagerBufferedRef a -> - t m (EagerBufferedRef b) + EagerBufferedRef (MBSStore m) a -> + t m (EagerBufferedRef (MBSStore (t m)) b) migrateEagerBufferedRef = migrateReference -instance (Show a) => Show (EagerBufferedRef a) where +instance (Show a) => Show (EagerBufferedRef store a) where show = show . ebrValue -makeEagerBufferedRef :: (MonadIO m) => BlobRef a -> a -> m (EagerBufferedRef a) +makeEagerBufferedRef :: (MonadIO m) => BlobRef store a -> a -> m (EagerBufferedRef store a) makeEagerBufferedRef r a = do ref <- liftIO $ newIORef r return $ EagerBufferedRef ref a -flushEagerBufferedRef :: (DirectBlobStorable m a) => EagerBufferedRef a -> m (BlobRef a) +flushEagerBufferedRef :: (DirectBlobStorable m a) => EagerBufferedRef (MBSStore m) a -> m (BlobRef (MBSStore m) a) flushEagerBufferedRef EagerBufferedRef{..} = do r <- liftIO $ readIORef ebrIORef if isNull r then do - (r' :: BlobRef a) <- fst <$> storeUpdateDirect ebrValue + (r' :: BlobRef store a) <- fst <$> storeUpdateDirect ebrValue liftIO . writeIORef ebrIORef $! r' return r' else return r -instance (DirectBlobStorable m a) => BlobStorable m (EagerBufferedRef a) where +instance (DirectBlobStorable m a, store ~ MBSStore m) => BlobStorable m (EagerBufferedRef store a) where load = do br <- get return $ do @@ -1223,14 +1236,14 @@ instance (DirectBlobStorable m a) => BlobStorable m (EagerBufferedRef a) where r <- liftIO $ readIORef ref if isNull r then do - (!r' :: BlobRef a, !v') <- storeUpdateDirect v + (!r' :: BlobRef store a, !v') <- storeUpdateDirect v liftIO $ writeIORef ref $! r' return (put r', EagerBufferedRef ref v') else do r' <- flushEagerBufferedRef ebr return (put r', ebr) -instance (Monad m, DirectBlobStorable m a) => Reference m EagerBufferedRef a where +instance (Monad m, DirectBlobStorable m a, store ~ MBSStore m) => Reference m store (EagerBufferedRef store) a where refMake = makeEagerBufferedRef refNull refLoad EagerBufferedRef{..} = return ebrValue refCache ebr = return (ebrValue ebr, ebr) @@ -1238,7 +1251,7 @@ instance (Monad m, DirectBlobStorable m a) => Reference m EagerBufferedRef a whe r <- liftIO $ readIORef ref if isNull r then do - (!r' :: BlobRef a, !v') <- storeUpdateDirect v + (!r' :: BlobRef store a, !v') <- storeUpdateDirect v liftIO $ writeIORef ref $! r' return (EagerBufferedRef ref v', r') else return (ebr, r) @@ -1249,48 +1262,48 @@ instance (Monad m, DirectBlobStorable m a) => Reference m EagerBufferedRef a whe {-# INLINE refCache #-} {-# INLINE refUncache #-} -instance (HashableTo h a) => HashableTo h (EagerBufferedRef a) where +instance (HashableTo h a) => HashableTo h (EagerBufferedRef store a) where getHash = getHash . ebrValue -instance (MHashableTo m h a) => MHashableTo m h (EagerBufferedRef a) where +instance (MHashableTo m h a) => MHashableTo m h (EagerBufferedRef store a) where getHashM = getHashM . ebrValue -instance (DirectBlobStorable m a) => BlobStorable m (Nullable (EagerBufferedRef a)) where +instance (DirectBlobStorable m a, store ~ MBSStore m) => BlobStorable m (Nullable (EagerBufferedRef store a)) where load = do - (r :: BlobRef a) <- get + (r :: BlobRef store a) <- get if isNull r then return (pure Null) else return $ do val <- loadDirect r Some <$> makeEagerBufferedRef r val - storeUpdate n@Null = return (put (refNull :: BlobRef a), n) + storeUpdate n@Null = return (put (refNull :: BlobRef store a), n) storeUpdate (Some v) = do (!r, !v') <- storeUpdate v return (r, Some v') -instance (Applicative m, Cacheable m a) => Cacheable m (EagerBufferedRef a) where +instance (Applicative m, Cacheable m a) => Cacheable m (EagerBufferedRef store a) where cache (EagerBufferedRef ioref v) = EagerBufferedRef ioref <$> cache v -- | Contents of a 'LazyBufferedRef'. -data LBR a - = LBRBlobbed !(BlobRef a) +data LBR store a + = LBRBlobbed !(BlobRef store a) | LBRMemory !a - | LBRBoth !(BlobRef a) !a + | LBRBoth !(BlobRef store a) !a -- | A 'LazyBufferedRef' is not read from the blob store when it is initially loaded. -- However, after the first time it is loaded, it does not need to be read from disk again. -newtype LazyBufferedRef a = LazyBufferedRef (IORef (LBR a)) +newtype LazyBufferedRef store a = LazyBufferedRef (IORef (LBR store a)) -instance Show (LazyBufferedRef a) where +instance Show (LazyBufferedRef store a) where show _ = "LazyBufferedRef" -- | Make a 'LazyBufferedRef' from a value. -- The value is not persisted to the store until the reference is flushed (e.g. with 'refFlush' or -- 'storeUpdate'). -makeLazyBufferedRef :: (MonadIO m) => a -> m (LazyBufferedRef a) +makeLazyBufferedRef :: (MonadIO m) => a -> m (LazyBufferedRef store a) makeLazyBufferedRef val = liftIO $ LazyBufferedRef <$!> newIORef (LBRMemory val) -instance (DirectBlobStorable m a) => Reference m LazyBufferedRef a where +instance (DirectBlobStorable m a, store ~ MBSStore m) => Reference m store (LazyBufferedRef store) a where refMake = makeLazyBufferedRef refLoad (LazyBufferedRef ior) = @@ -1324,7 +1337,7 @@ instance (DirectBlobStorable m a) => Reference m LazyBufferedRef a where liftIO $ writeIORef ior (LBRBlobbed br) return r -instance (DirectBlobStorable m a) => BlobStorable m (LazyBufferedRef a) where +instance (DirectBlobStorable m a, store ~ MBSStore m) => BlobStorable m (LazyBufferedRef store a) where load = do br <- get return $ liftIO $ LazyBufferedRef <$!> newIORef (LBRBlobbed br) @@ -1332,18 +1345,18 @@ instance (DirectBlobStorable m a) => BlobStorable m (LazyBufferedRef a) where (_, !r) <- refFlush lbr return (put r, lbr) -instance (DirectBlobStorable m a) => BlobStorable m (Nullable (LazyBufferedRef a)) where +instance (DirectBlobStorable m a, store ~ MBSStore m) => BlobStorable m (Nullable (LazyBufferedRef store a)) where load = do br <- get if isNull br then return (pure Null) else return $ liftIO $ Some . LazyBufferedRef <$!> newIORef (LBRBlobbed br) - storeUpdate n@Null = return (put (refNull :: BlobRef a), n) + storeUpdate n@Null = return (put (refNull :: BlobRef store a), n) storeUpdate m@(Some lbr) = do (!r, _) <- storeUpdate lbr return (r, m) -instance (DirectBlobStorable m a, BlobStorable m b) => BlobStorable m (Nullable (LazyBufferedRef a, b)) where +instance (DirectBlobStorable m a, BlobStorable m b, store ~ MBSStore m) => BlobStorable m (Nullable (LazyBufferedRef store a, b)) where load = do br <- get if isNull br @@ -1353,12 +1366,12 @@ instance (DirectBlobStorable m a, BlobStorable m b) => BlobStorable m (Nullable return $ do binner <- bval liftIO $ Some . (,binner) . LazyBufferedRef <$!> newIORef (LBRBlobbed br) - storeUpdate n@Null = return (put (refNull :: BlobRef a), n) + storeUpdate n@Null = return (put (refNull :: BlobRef store a), n) storeUpdate (Some p) = do (!r, !p') <- storeUpdate p return (r, Some p') -instance (MHashableTo m h a, DirectBlobStorable m a) => MHashableTo m h (LazyBufferedRef a) where +instance (MHashableTo m h a, DirectBlobStorable m a, store ~ MBSStore m) => MHashableTo m h (LazyBufferedRef store a) where getHashM = getHashM <=< refLoad -- | A reference that is generally not retained in memory once it has been written to disk, unless @@ -1367,54 +1380,54 @@ instance (MHashableTo m h a, DirectBlobStorable m a) => MHashableTo m h (LazyBuf -- -- This is essentially a simplified version of 'BufferedRef', where @BRBoth ref v@ is simply -- replaced with @URBlobbed ref@. -data UnbufferedRef a +data UnbufferedRef store a = -- | A reference that is already on disk - URBlobbed !(BlobRef a) + URBlobbed !(BlobRef store a) | -- | A reference that is in memory and may have been written to disk. -- If the reference has not been written, the 'urIORef' will contain 'refNull'. -- If it has been written, the 'BlobRef' will be a valid (non-null) reference to the -- stored value. - URMemory {urIORef :: !(IORef (BlobRef a)), urValue :: !a} + URMemory {urIORef :: !(IORef (BlobRef store a)), urValue :: !a} -instance (Show a) => Show (UnbufferedRef a) where +instance (Show a) => Show (UnbufferedRef store a) where show (URBlobbed r) = show r show (URMemory _ v) = "{" ++ show v ++ "}" -instance (DirectBlobStorable m a) => BlobStorable m (UnbufferedRef a) where +instance (DirectBlobStorable m a, store ~ MBSStore m) => BlobStorable m (UnbufferedRef store a) where load = fmap URBlobbed <$> load storeUpdate ur = do (ur', !r) <- refFlush ur return (put r, ur') -instance (DirectBlobStorable m a) => BlobStorable m (Nullable (UnbufferedRef a)) where +instance (DirectBlobStorable m a, store ~ MBSStore m) => BlobStorable m (Nullable (UnbufferedRef store a)) where load = do r <- get if isNull r then return (pure Null) else return (pure (Some (URBlobbed r))) - storeUpdate n@Null = return (put (refNull :: BlobRef a), n) + storeUpdate n@Null = return (put (refNull :: BlobRef store a), n) storeUpdate (Some v) = do (!r, !v') <- storeUpdate v return (r, Some v') -- | Make an 'UnbufferedRef' from a value. -makeUnbufferedRef :: (MonadIO m) => a -> m (UnbufferedRef a) +makeUnbufferedRef :: (MonadIO m) => a -> m (UnbufferedRef store a) makeUnbufferedRef urValue = do urIORef <- liftIO $ newIORef refNull return $! URMemory{..} -- | Make an 'UnbufferedRef' from a value that is immediately flushed to the blob store. -- This is equivalent to @refFlush <=< refMake@. -makeFlushedUnbufferedRef :: (DirectBlobStorable m a) => a -> m (UnbufferedRef a) +makeFlushedUnbufferedRef :: (DirectBlobStorable m a) => a -> m (UnbufferedRef (MBSStore m) a) makeFlushedUnbufferedRef val = do (r, _) <- storeUpdateDirect val return $! URBlobbed r -- | Create an 'UnbufferedRef' from a 'BlobRef'. -blobRefToUnbufferedRef :: BlobRef a -> UnbufferedRef a +blobRefToUnbufferedRef :: BlobRef store a -> UnbufferedRef store a blobRefToUnbufferedRef = URBlobbed -instance (DirectBlobStorable m a) => Reference m UnbufferedRef a where +instance (DirectBlobStorable m a, store ~ MBSStore m) => Reference m store (UnbufferedRef store) a where refMake = makeUnbufferedRef refLoad (URBlobbed ref) = loadDirect ref @@ -1438,7 +1451,7 @@ instance (DirectBlobStorable m a) => Reference m UnbufferedRef a where refUncache = fmap fst <$> refFlush -instance (DirectBlobStorable m a, MHashableTo m h a) => MHashableTo m h (UnbufferedRef a) where +instance (DirectBlobStorable m a, MHashableTo m h a, store ~ MBSStore m) => MHashableTo m h (UnbufferedRef store a) where getHashM ref = getHashM =<< refLoad ref -- | 'BufferedFix' is a fixed-point combinator that uses a 'BufferedRef'. @@ -1455,27 +1468,27 @@ instance (DirectBlobStorable m a, MHashableTo m h a) => MHashableTo m h (Unbuffe -- The use of fixed point combinators such as this allows us to implement recursive -- data-structures independently of how the recursion is handled (e.g. via 'BufferedRef' -- as in this case, or without references as with 'Fix'). -newtype BufferedFix f = BufferedFix {unBF :: BufferedRef (f (BufferedFix f))} +newtype BufferedFix store f = BufferedFix {unBF :: BufferedRef store (f (BufferedFix store f))} -type instance Base (BufferedFix f) = f +type instance Base (BufferedFix store f) = f -instance (MonadBlobStore m, DirectBlobStorable m (f (BufferedFix f))) => BlobStorable m (BufferedFix f) where +instance (MonadBlobStore m, DirectBlobStorable m (f (BufferedFix store f)), store ~ MBSStore m) => BlobStorable m (BufferedFix store f) where load = fmap BufferedFix <$> load storeUpdate bf = do (!p, !r) <- storeUpdate (unBF bf) return (p, BufferedFix r) -instance (MonadBlobStore m, DirectBlobStorable m (f (BufferedFix f))) => BlobStorable m (Nullable (BufferedFix f)) where +instance (MonadBlobStore m, DirectBlobStorable m (f (BufferedFix store f)), store ~ MBSStore m) => BlobStorable m (Nullable (BufferedFix store f)) where load = fmap (fmap BufferedFix) <$> load storeUpdate bf = do (!p, !r) <- storeUpdate (fmap unBF bf) return (p, BufferedFix <$> r) -instance (Monad m, DirectBlobStorable m (f (BufferedFix f))) => MRecursive m (BufferedFix f) where +instance (Monad m, DirectBlobStorable m (f (BufferedFix store f)), store ~ MBSStore m) => MRecursive m (BufferedFix store f) where mproject = refLoad . unBF {-# INLINE mproject #-} -instance (MonadIO m) => MCorecursive m (BufferedFix f) where +instance (MonadIO m) => MCorecursive m (BufferedFix store f) where membed = fmap BufferedFix . makeBufferedRef {-# INLINE membed #-} @@ -1490,39 +1503,39 @@ class FixShowable fix where fix f -> String -instance FixShowable BufferedFix where +instance FixShowable (BufferedFix store) where showFix _ (BufferedFix (BRBlobbed r)) = show r showFix sh (BufferedFix (BRMemory _ v)) = sh (showFix sh <$> v) showFix sh (BufferedFix (BRBoth _ v)) = sh (showFix sh <$> v) -instance (Functor m, DirectBlobStorable m (f (BufferedFix f)), Cacheable m (f (BufferedFix f))) => Cacheable m (BufferedFix f) where +instance (Functor m, DirectBlobStorable m (f (BufferedFix store f)), store ~ MBSStore m, Cacheable m (f (BufferedFix store f))) => Cacheable m (BufferedFix store f) where cache = fmap BufferedFix . cache . unBF -- | 'UnbufferedFix' is a fixed-point combinator that uses an 'UnbufferedRef'. -- (See also 'BufferedFix'.) -newtype UnbufferedFix f = UnbufferedFix {unUF :: UnbufferedRef (f (UnbufferedFix f))} +newtype UnbufferedFix store f = UnbufferedFix {unUF :: UnbufferedRef store (f (UnbufferedFix store f))} -type instance Base (UnbufferedFix f) = f +type instance Base (UnbufferedFix store f) = f -instance (MonadBlobStore m, DirectBlobStorable m (f (UnbufferedFix f))) => BlobStorable m (UnbufferedFix f) where +instance (MonadBlobStore m, DirectBlobStorable m (f (UnbufferedFix store f)), store ~ MBSStore m) => BlobStorable m (UnbufferedFix store f) where load = fmap UnbufferedFix <$> load storeUpdate uf = do (!p, !r) <- storeUpdate (unUF uf) return (p, UnbufferedFix r) -instance (MonadBlobStore m, DirectBlobStorable m (f (UnbufferedFix f))) => BlobStorable m (Nullable (UnbufferedFix f)) where +instance (MonadBlobStore m, DirectBlobStorable m (f (UnbufferedFix store f)), store ~ MBSStore m) => BlobStorable m (Nullable (UnbufferedFix store f)) where load = fmap (fmap UnbufferedFix) <$> load storeUpdate bf = do (!p, !r) <- storeUpdate (fmap unUF bf) return (p, UnbufferedFix <$> r) -instance (MonadBlobStore m, DirectBlobStorable m (f (UnbufferedFix f))) => MRecursive m (UnbufferedFix f) where +instance (MonadBlobStore m, DirectBlobStorable m (f (UnbufferedFix store f)), store ~ MBSStore m) => MRecursive m (UnbufferedFix store f) where mproject = refLoad . unUF -instance (MonadIO m) => MCorecursive m (UnbufferedFix f) where +instance (MonadIO m) => MCorecursive m (UnbufferedFix store f) where membed = fmap UnbufferedFix . makeUnbufferedRef -instance FixShowable UnbufferedFix where +instance FixShowable (UnbufferedFix store) where showFix _ (UnbufferedFix (URBlobbed r)) = show r showFix sh (UnbufferedFix (URMemory _ v)) = sh (showFix sh <$> v) @@ -1590,8 +1603,8 @@ deriving newtype instance (MHashableTo m h a) => MHashableTo m h (StoreSerialize -- -- Note, the hash is not computed when the reference is loaded with 'load', or dereferenced -- with 'refLoad'. None of the operations cause the hash to be dropped. -data HashedBufferedRef' h a = HashedBufferedRef - { bufferedReference :: !(BufferedRef a), +data HashedBufferedRef' h store a = HashedBufferedRef + { bufferedReference :: !(BufferedRef store a), bufferedHash :: !(IORef (Nullable h)) } @@ -1600,8 +1613,8 @@ data HashedBufferedRef' h a = HashedBufferedRef -- disk, as well as cached in memory. migrateHashedBufferedRefKeepHash :: (MonadTrans t, BlobStorable m a, BlobStorable (t m) a) => - HashedBufferedRef' h a -> - t m (HashedBufferedRef' h a) + HashedBufferedRef' h (MBSStore m) a -> + t m (HashedBufferedRef' h (MBSStore (t m)) a) migrateHashedBufferedRefKeepHash hb = do !newRef <- refMake =<< lift (refLoad (bufferedReference hb)) -- carry over the hash @@ -1621,8 +1634,8 @@ migrateHashedBufferedRefKeepHash hb = do migrateHashedBufferedRef :: (MonadTrans t, MHashableTo (t m) h2 b, BlobStorable m a, BlobStorable (t m) b) => (a -> t m b) -> - HashedBufferedRef' h1 a -> - t m (HashedBufferedRef' h2 b) + HashedBufferedRef' h1 (MBSStore m) a -> + t m (HashedBufferedRef' h2 (MBSStore (t m)) b) migrateHashedBufferedRef f hb = do !newRef <- refMake =<< f =<< lift (refLoad (bufferedReference hb)) -- compute the hash while the data is in memory. @@ -1637,7 +1650,7 @@ migrateHashedBufferedRef f hb = do type HashedBufferedRef = HashedBufferedRef' H.Hash -- | Created a 'HashedBufferedRef' value from a 'Hashed' value, retaining the hash. -bufferHashed :: (MonadIO m) => Hashed' h a -> m (HashedBufferedRef' h a) +bufferHashed :: (MonadIO m) => Hashed' h a -> m (HashedBufferedRef' h store a) bufferHashed (Hashed !val !h) = do br <- makeBufferedRef val hashRef <- liftIO $ newIORef (Some h) @@ -1645,13 +1658,13 @@ bufferHashed (Hashed !val !h) = do -- | Make a 'HashedBufferedRef'' to a given value. This does not compute the hash, which is done -- on demand. -makeHashedBufferedRef :: (MonadIO m) => a -> m (HashedBufferedRef' h a) +makeHashedBufferedRef :: (MonadIO m) => a -> m (HashedBufferedRef' h store a) makeHashedBufferedRef val = do br <- makeBufferedRef val hashRef <- liftIO $ newIORef Null return $ HashedBufferedRef br hashRef -instance (DirectBlobStorable m a, MHashableTo m h a) => MHashableTo m h (HashedBufferedRef' h a) where +instance (DirectBlobStorable m a, MHashableTo m h a, store ~ MBSStore m) => MHashableTo m h (HashedBufferedRef' h store a) where getHashM HashedBufferedRef{..} = liftIO (readIORef bufferedHash) >>= \case Null -> do @@ -1660,10 +1673,10 @@ instance (DirectBlobStorable m a, MHashableTo m h a) => MHashableTo m h (HashedB return h Some h -> return h -instance (Show a) => Show (HashedBufferedRef' h a) where +instance (Show a) => Show (HashedBufferedRef' h store a) where show ref = show (bufferedReference ref) -instance (DirectBlobStorable m a) => BlobStorable m (HashedBufferedRef' h a) where +instance (DirectBlobStorable m a, store ~ MBSStore m) => BlobStorable m (HashedBufferedRef' h store a) where load = do -- deserialize the reference and keep it as blobbed mbufferedReference <- load @@ -1675,7 +1688,7 @@ instance (DirectBlobStorable m a) => BlobStorable m (HashedBufferedRef' h a) whe (!pt, !br) <- storeUpdate brm return (pt, HashedBufferedRef br hRef) -instance (Monad m, DirectBlobStorable m a, MHashableTo m h a) => Reference m (HashedBufferedRef' h) a where +instance (Monad m, DirectBlobStorable m a, MHashableTo m h a, store ~ MBSStore m) => Reference m store (HashedBufferedRef' h store) a where refFlush ref = do (!br, !r) <- flushBufferedRef (bufferedReference ref) return (HashedBufferedRef br (bufferedHash ref), r) @@ -1705,15 +1718,15 @@ instance (Monad m, DirectBlobStorable m a, MHashableTo m h a) => Reference m (Ha {-# INLINE refCache #-} {-# INLINE refUncache #-} -instance (DirectBlobStorable m a) => BlobStorable m (Nullable (HashedBufferedRef' h a)) where +instance (DirectBlobStorable m a, store ~ MBSStore m) => BlobStorable m (Nullable (HashedBufferedRef' h store a)) where load = do - (r :: BlobRef a) <- get + (r :: BlobRef store a) <- get if isNull r then return (pure Null) else return $ do hashRef <- liftIO $ newIORef Null pure $ Some $ HashedBufferedRef (BRBlobbed r) hashRef - storeUpdate n@Null = return (put (refNull :: BlobRef a), n) + storeUpdate n@Null = return (put (refNull :: BlobRef store a), n) storeUpdate (Some v) = do (!r, !v') <- storeUpdate v return (r, Some v') @@ -1721,11 +1734,11 @@ instance (DirectBlobStorable m a) => BlobStorable m (Nullable (HashedBufferedRef -- | A wrapped 'HashedBufferedRef'. -- If the constraint for the 'OParam' is satisfied this yields a 'HashedBufferedRef' otherwise -- it yields a 'NoParam'. -type HashedBufferedRefO (pt :: ParameterType) (cpv :: ChainParametersVersion) a = OParam pt cpv (HashedBufferedRef a) +type HashedBufferedRefO store (pt :: ParameterType) (cpv :: ChainParametersVersion) a = OParam pt cpv (HashedBufferedRef store a) instance - (DirectBlobStorable m a, IsParameterType pt, IsChainParametersVersion cpv) => - BlobStorable m (HashedBufferedRefO pt cpv a) + (DirectBlobStorable m a, store ~ MBSStore m, IsParameterType pt, IsChainParametersVersion cpv) => + BlobStorable m (HashedBufferedRefO store pt cpv a) where load = sequence <$> whenSupportedA load @@ -1736,8 +1749,8 @@ instance -- | An 'EagerBufferedRef' accompanied by a hash. -- Both the value and the hash are retained in memory by this reference. -data EagerlyHashedBufferedRef' h a = EagerlyHashedBufferedRef - { ehbrReference :: {-# UNPACK #-} !(EagerBufferedRef a), +data EagerlyHashedBufferedRef' h store a = EagerlyHashedBufferedRef + { ehbrReference :: {-# UNPACK #-} !(EagerBufferedRef store a), ehbrHash :: !h } @@ -1746,20 +1759,20 @@ type EagerlyHashedBufferedRef = EagerlyHashedBufferedRef' H.Hash -- | Migrate an 'EagerlyHashedBufferedRef' **assuming the migration does not -- change the hash**. The hash is carried over and not recomputed. migrateEagerlyHashedBufferedRefKeepHash :: - (BlobStorable m a, BlobStorable (t m) a, MonadTrans t) => - (a -> t m a) -> - EagerlyHashedBufferedRef' h a -> - t m (EagerlyHashedBufferedRef' h a) + (BlobStorable m a, BlobStorable (t m) b, MonadTrans t) => + (a -> t m b) -> + EagerlyHashedBufferedRef' h (MBSStore m) a -> + t m (EagerlyHashedBufferedRef' h (MBSStore (t m)) b) migrateEagerlyHashedBufferedRefKeepHash f r = do ehbrReference <- migrateEagerBufferedRef f (ehbrReference r) return $! r{ehbrReference = ehbrReference} -instance HashableTo h (EagerlyHashedBufferedRef' h a) where +instance HashableTo h (EagerlyHashedBufferedRef' h store a) where getHash = ehbrHash -instance (Monad m) => MHashableTo m h (EagerlyHashedBufferedRef' h a) +instance (Monad m) => MHashableTo m h (EagerlyHashedBufferedRef' h store a) -instance (BlobStorable m a, MHashableTo m h a) => BlobStorable m (EagerlyHashedBufferedRef' h a) where +instance (BlobStorable m a, store ~ MBSStore m, MHashableTo m h a) => BlobStorable m (EagerlyHashedBufferedRef' h store a) where load = do mref <- load return $ do @@ -1774,27 +1787,27 @@ instance (BlobStorable m a, MHashableTo m h a) => BlobStorable m (EagerlyHashedB {-# INLINE storeUpdate #-} -- | Convert a 'BlobRef' to an 'EagerlyHashedBufferedRef'. -blobRefToEagerlyHashedBufferedRef :: (BlobStorable m a, MHashableTo m h a) => BlobRef a -> m (EagerlyHashedBufferedRef' h a) +blobRefToEagerlyHashedBufferedRef :: (BlobStorable m a, store ~ MBSStore m, MHashableTo m h a) => BlobRef store a -> m (EagerlyHashedBufferedRef' h store a) blobRefToEagerlyHashedBufferedRef ref = do val <- loadRef ref ehbrReference <- makeEagerBufferedRef ref val ehbrHash <- getHashM val return $! EagerlyHashedBufferedRef{..} -instance (BlobStorable m a, MHashableTo m h a) => BlobStorable m (Nullable (EagerlyHashedBufferedRef' h a)) where +instance (BlobStorable m a, store ~ MBSStore m, MHashableTo m h a) => BlobStorable m (Nullable (EagerlyHashedBufferedRef' h store a)) where load = do - (r :: BlobRef a) <- get + (r :: BlobRef store a) <- get if isNull r then return (pure Null) else return $ Some <$> blobRefToEagerlyHashedBufferedRef r - storeUpdate n@Null = return (put (refNull :: BlobRef a), n) + storeUpdate n@Null = return (put (refNull :: BlobRef store a), n) storeUpdate (Some v) = do (!r, !v') <- storeUpdate v return (r, Some v') -instance (BlobStorable m a, MHashableTo m h a, BlobStorable m b) => BlobStorable m (Nullable (EagerlyHashedBufferedRef' h a, b)) where +instance (BlobStorable m a, store ~ MBSStore m, MHashableTo m h a, BlobStorable m b) => BlobStorable m (Nullable (EagerlyHashedBufferedRef' h store a, b)) where load = do - (r :: BlobRef a) <- get + (r :: BlobRef store a) <- get if isNull r then return (pure Null) else do @@ -1803,12 +1816,12 @@ instance (BlobStorable m a, MHashableTo m h a, BlobStorable m b) => BlobStorable binner <- bval ehbr <- blobRefToEagerlyHashedBufferedRef r pure $ Some (ehbr, binner) - storeUpdate n@Null = return (put (refNull :: BlobRef a), n) + storeUpdate n@Null = return (put (refNull :: BlobRef store a), n) storeUpdate (Some v) = do (!r, !v') <- storeUpdate v return (r, Some v') -instance (Monad m, BlobStorable m a, MHashableTo m h a) => Reference m (EagerlyHashedBufferedRef' h) a where +instance (Monad m, BlobStorable m a, store ~ MBSStore m, MHashableTo m h a) => Reference m store (EagerlyHashedBufferedRef' h store) a where refFlush ref = do (!br, !r) <- refFlush (ehbrReference ref) return (EagerlyHashedBufferedRef br (ehbrHash ref), r) @@ -1833,7 +1846,7 @@ instance (Monad m, BlobStorable m a, MHashableTo m h a) => Reference m (EagerlyH {-# INLINE refCache #-} {-# INLINE refUncache #-} -instance (Show h, Show a) => Show (EagerlyHashedBufferedRef' h a) where +instance (Show h, Show a) => Show (EagerlyHashedBufferedRef' h store a) where show ref = show (ehbrReference ref) ++ " with hash: " ++ show (ehbrHash ref) -- | This class abstracts values that can be cached in some monad. @@ -1850,7 +1863,7 @@ instance (Applicative m, Cacheable m a) => Cacheable m (Nullable a) where instance (Applicative m, Cacheable m a) => Cacheable m (OParam pt cpv a) where cache = traverse cache -instance (DirectBlobStorable m a, Cacheable m a) => Cacheable m (BufferedRef a) where +instance (DirectBlobStorable m a, store ~ MBSStore m, Cacheable m a) => Cacheable m (BufferedRef store a) where cache BRBlobbed{..} = do brValue <- cache =<< loadDirect brRef return BRBoth{..} @@ -1861,7 +1874,7 @@ instance (DirectBlobStorable m a, Cacheable m a) => Cacheable m (BufferedRef a) cachedVal <- cache brValue return $! br{brValue = cachedVal} -instance (MHashableTo m h a, DirectBlobStorable m a, Cacheable m a) => Cacheable m (HashedBufferedRef' h a) where +instance (MHashableTo m h a, DirectBlobStorable m a, store ~ MBSStore m, Cacheable m a) => Cacheable m (HashedBufferedRef' h store a) where cache (HashedBufferedRef ref hshRef) = do ref' <- cache ref currentHash <- liftIO (readIORef hshRef) @@ -1870,7 +1883,7 @@ instance (MHashableTo m h a, DirectBlobStorable m a, Cacheable m a) => Cacheable liftIO $ writeIORef hshRef $! Some h return (HashedBufferedRef ref' hshRef) -instance (BlobStorable m a, Cacheable m a) => Cacheable m (EagerlyHashedBufferedRef' h a) where +instance (BlobStorable m a, Cacheable m a) => Cacheable m (EagerlyHashedBufferedRef' h store a) where cache r = do ref' <- cache (ehbrReference r) return $! r{ehbrReference = ref'} @@ -1920,7 +1933,7 @@ class Cacheable1 m c a where -- type. liftCache :: (a -> m a) -> c -> m c -instance (DirectBlobStorable m a) => Cacheable1 m (BufferedRef a) a where +instance (DirectBlobStorable m a, store ~ MBSStore m) => Cacheable1 m (BufferedRef store a) a where liftCache cch BRBlobbed{..} = do brValue <- cch =<< loadDirect brRef return BRBoth{..} @@ -1931,7 +1944,7 @@ instance (DirectBlobStorable m a) => Cacheable1 m (BufferedRef a) a where cachedVal <- cch brValue return $! br{brValue = cachedVal} -instance (MHashableTo m h a, DirectBlobStorable m a) => Cacheable1 m (HashedBufferedRef' h a) a where +instance (MHashableTo m h a, DirectBlobStorable m a, store ~ MBSStore m) => Cacheable1 m (HashedBufferedRef' h store a) a where liftCache cch (HashedBufferedRef ref hshRef) = do ref' <- liftCache cch ref currentHash <- liftIO (readIORef hshRef) diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState/AccountReleaseSchedule.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState/AccountReleaseSchedule.hs index 5c3dcd0165..d4616b52eb 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState/AccountReleaseSchedule.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState/AccountReleaseSchedule.hs @@ -108,21 +108,21 @@ import Lens.Micro.Platform -- | A release represents the data that will be stored in the disk for each -- amount that has to be unlocked. Releases form a Null-terminated chain of -- @HashedBufferedRef@s. -data Release = Release +data Release store = Release { _rTimestamp :: !Timestamp, _rAmount :: !Amount, - _rNext :: !(Nullable (EagerlyHashedBufferedRef Release)) + _rNext :: !(Nullable (EagerlyHashedBufferedRef store (Release store))) } deriving (Show) -migrateRelease :: (SupportMigration m t) => Release -> t m Release +migrateRelease :: (SupportMigration m t) => Release (MBSStore m) -> t m (Release (MBSStore (t m))) migrateRelease r = do newNext <- forM (_rNext r) $ migrateEagerlyHashedBufferedRefKeepHash migrateRelease return r{_rNext = newNext} -- | As every link in the chain is a HashedBufferedRef, when computing the hash -- of a release we will compute the hash of @timestamp <> amount <> nextHash@. -instance (MonadBlobStore m) => MHashableTo m Hash Release where +instance (MonadBlobStore m) => MHashableTo m Hash (Release store) where getHashM rel = go (put (_rTimestamp rel) >> put (_rAmount rel)) (_rNext rel) where go partial Null = return $ hash $ runPut partial @@ -130,7 +130,7 @@ instance (MonadBlobStore m) => MHashableTo m Hash Release where nextHash <- getHashM r return $ hash (runPut partial <> hashToByteString nextHash) -instance (MonadBlobStore m) => BlobStorable m Release where +instance (MonadBlobStore m, store ~ MBSStore m) => BlobStorable m (Release store) where storeUpdate r@Release{..} = do (pNext, _rNext') <- storeUpdate _rNext return @@ -149,8 +149,8 @@ instance (MonadBlobStore m) => BlobStorable m Release where -- | Stores schedules. New items are inserted with 'addReleases' and are removed -- with 'unlockAmountsUntil'. -data AccountReleaseSchedule = AccountReleaseSchedule - { _arsValues :: !(Vector (Nullable (EagerlyHashedBufferedRef Release, TransactionHash))), +data AccountReleaseSchedule store = AccountReleaseSchedule + { _arsValues :: !(Vector (Nullable (EagerlyHashedBufferedRef store (Release store), TransactionHash))), _arsPrioQueue :: !(Map Timestamp [Int]), _arsTotalLockedUpBalance :: !Amount } @@ -158,7 +158,10 @@ data AccountReleaseSchedule = AccountReleaseSchedule makeLenses ''AccountReleaseSchedule -migratePersistentAccountReleaseSchedule :: (SupportMigration m t) => AccountReleaseSchedule -> t m AccountReleaseSchedule +migratePersistentAccountReleaseSchedule :: + (SupportMigration m t) => + AccountReleaseSchedule (MBSStore m) -> + t m (AccountReleaseSchedule (MBSStore (t m))) migratePersistentAccountReleaseSchedule AccountReleaseSchedule{..} = do newValues <- forM _arsValues $ \n -> do forM n $ \(hf, r) -> (,r) <$> migrateEagerlyHashedBufferedRefKeepHash migrateRelease hf @@ -169,7 +172,7 @@ migratePersistentAccountReleaseSchedule AccountReleaseSchedule{..} = do _arsTotalLockedUpBalance = _arsTotalLockedUpBalance } -instance (MonadBlobStore m) => BlobStorable m AccountReleaseSchedule where +instance (MonadBlobStore m, store ~ MBSStore m) => BlobStorable m (AccountReleaseSchedule store) where storeUpdate AccountReleaseSchedule{..} = do let !len = Vector.length _arsValues let f item = do @@ -204,7 +207,7 @@ instance (MonadBlobStore m) => BlobStorable m AccountReleaseSchedule where -- | @hash(AccountReleaseSchedule(releases) = hash (foldl (\h i -> h <> hash i) -- mempty) releases@ so @hash (hash a_1 <> hash a_2 <> ... <> hash a_n)@ -instance (MonadBlobStore m) => MHashableTo m Transient.AccountReleaseScheduleHashV0 AccountReleaseSchedule where +instance (MonadBlobStore m) => MHashableTo m Transient.AccountReleaseScheduleHashV0 (AccountReleaseSchedule store) where getHashM AccountReleaseSchedule{..} = if _arsTotalLockedUpBalance == 0 then return Transient.emptyAccountReleaseScheduleHashV0 @@ -220,23 +223,27 @@ instance (MonadBlobStore m) => MHashableTo m Transient.AccountReleaseScheduleHas BS.empty _arsValues -instance (MonadBlobStore m) => Cacheable m AccountReleaseSchedule +instance (MonadBlobStore m) => Cacheable m (AccountReleaseSchedule store) ------------------------------------- API -------------------------------------- -- | The empty account release schedule. -emptyAccountReleaseSchedule :: AccountReleaseSchedule +emptyAccountReleaseSchedule :: AccountReleaseSchedule store emptyAccountReleaseSchedule = AccountReleaseSchedule Vector.empty Map.empty 0 -- | Returns 'True' if the account release schedule contains no releases. -isEmptyAccountReleaseSchedule :: AccountReleaseSchedule -> Bool +isEmptyAccountReleaseSchedule :: AccountReleaseSchedule store -> Bool isEmptyAccountReleaseSchedule = Map.null . _arsPrioQueue -- | Insert a new schedule in the structure. -- -- Precondition: The given list of timestamps and amounts MUST NOT be empty, and be in ascending -- order of timestamps. -addReleases :: (MonadBlobStore m) => ([(Timestamp, Amount)], TransactionHash) -> AccountReleaseSchedule -> m AccountReleaseSchedule +addReleases :: + (MonadBlobStore m) => + ([(Timestamp, Amount)], TransactionHash) -> + AccountReleaseSchedule (MBSStore m) -> + m (AccountReleaseSchedule (MBSStore m)) addReleases (l, txh) ars = do -- get the index that will be used with this new item let itemIndex = length $ ars ^. arsValues @@ -264,7 +271,11 @@ addReleases (l, txh) ars = do -- | Returns the amount that was unlocked, the next timestamp for this account -- (if there is one) and the new account release schedule after removing the -- amounts whose timestamp was less or equal to the given timestamp. -unlockAmountsUntil :: (MonadBlobStore m) => Timestamp -> AccountReleaseSchedule -> m (Amount, Maybe Timestamp, AccountReleaseSchedule) +unlockAmountsUntil :: + (MonadBlobStore m) => + Timestamp -> + AccountReleaseSchedule (MBSStore m) -> + m (Amount, Maybe Timestamp, AccountReleaseSchedule (MBSStore m)) unlockAmountsUntil up ars = do let (toRemove, x, toKeep) = Map.splitLookup up (ars ^. arsPrioQueue) if Map.null toKeep @@ -329,7 +340,7 @@ pickNthResultM f i num --------------------------------- Conversions ---------------------------------- -storePersistentAccountReleaseSchedule :: (MonadBlobStore m) => Transient.AccountReleaseSchedule -> m AccountReleaseSchedule +storePersistentAccountReleaseSchedule :: (MonadBlobStore m) => Transient.AccountReleaseSchedule -> m (AccountReleaseSchedule (MBSStore m)) storePersistentAccountReleaseSchedule Transient.AccountReleaseSchedule{..} = do let persistTransientReleases (Transient.Release thisTimestamp thisAmount) nextRelease = Some <$> refMake (Release thisTimestamp thisAmount nextRelease) @@ -347,7 +358,7 @@ storePersistentAccountReleaseSchedule Transient.AccountReleaseSchedule{..} = do .. } -loadPersistentAccountReleaseSchedule :: (MonadBlobStore m) => AccountReleaseSchedule -> m Transient.AccountReleaseSchedule +loadPersistentAccountReleaseSchedule :: (MonadBlobStore m) => AccountReleaseSchedule (MBSStore m) -> m Transient.AccountReleaseSchedule loadPersistentAccountReleaseSchedule AccountReleaseSchedule{..} = do _values <- Vector.mapM @@ -370,16 +381,16 @@ loadPersistentAccountReleaseSchedule AccountReleaseSchedule{..} = do } -- | Get the total locked up balance on an 'AccountReleaseSchedule'. -releaseScheduleLockedBalance :: AccountReleaseSchedule -> Amount +releaseScheduleLockedBalance :: AccountReleaseSchedule store -> Amount releaseScheduleLockedBalance = _arsTotalLockedUpBalance -- | Get the timestamp at which the next scheduled release will occur (if any). -nextReleaseTimestamp :: AccountReleaseSchedule -> Maybe Timestamp +nextReleaseTimestamp :: AccountReleaseSchedule store -> Maybe Timestamp nextReleaseTimestamp = fmap fst . Map.lookupMin . _arsPrioQueue -- | List a release as timestamp and amount pairs. -- The list will never be empty. -listRelease :: (MonadBlobStore m) => Release -> m [(Timestamp, Amount)] +listRelease :: (MonadBlobStore m) => Release (MBSStore m) -> m [(Timestamp, Amount)] listRelease loadedRelease = do next <- case _rNext loadedRelease of Null -> return [] diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState/AccountReleaseScheduleV1.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState/AccountReleaseScheduleV1.hs index c686bde263..2ad112e373 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState/AccountReleaseScheduleV1.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState/AccountReleaseScheduleV1.hs @@ -84,7 +84,7 @@ hashReleasesFrom dropCount Releases{..} = -- | A release schedule produced by a single scheduled transfer. An account can -- have any number (including 0) of release schedule entries. -data ReleaseScheduleEntry = ReleaseScheduleEntry +data ReleaseScheduleEntry store = ReleaseScheduleEntry { -- | Timestamp of the next release. rseNextTimestamp :: !Timestamp, -- | Hash derived from the releases (given the next release index). @@ -92,13 +92,13 @@ data ReleaseScheduleEntry = ReleaseScheduleEntry -- | Reference to the releases. The releases are only stored once and never -- updated. Instead the 'rseNextReleaseIndex' is updated to indicate where -- in the list of releases is the current start of locked amounts. - rseReleasesRef :: !(LazyBufferedRef Releases), + rseReleasesRef :: !(LazyBufferedRef store Releases), -- | Index of the next release. rseNextReleaseIndex :: !Word64 } deriving (Show) -instance (MonadBlobStore m) => BlobStorable m ReleaseScheduleEntry where +instance (MonadBlobStore m, store ~ MBSStore m) => BlobStorable m (ReleaseScheduleEntry store) where storeUpdate ReleaseScheduleEntry{..} = do (pReleases, newReleasesRef) <- storeUpdate rseReleasesRef let !p = do @@ -120,15 +120,15 @@ instance (MonadBlobStore m) => BlobStorable m ReleaseScheduleEntry where -- 'ReleaseScheduleEntry', and they are maintained ordered by this key. The -- ordering is first by timestamp, and ties are resolved by the hash of the -- releases. -rseSortKey :: ReleaseScheduleEntry -> (Timestamp, Hash.Hash) +rseSortKey :: ReleaseScheduleEntry store -> (Timestamp, Hash.Hash) rseSortKey ReleaseScheduleEntry{..} = (rseNextTimestamp, rseReleasesHash) -newtype AccountReleaseSchedule = AccountReleaseSchedule +newtype AccountReleaseSchedule store = AccountReleaseSchedule { -- | The release entries ordered on 'rseSortKey'. - arsReleases :: Vector ReleaseScheduleEntry + arsReleases :: Vector (ReleaseScheduleEntry store) } -instance (MonadBlobStore m) => BlobStorable m AccountReleaseSchedule where +instance (MonadBlobStore m, store ~ MBSStore m) => BlobStorable m (AccountReleaseSchedule store) where storeUpdate AccountReleaseSchedule{..} = do storeReleases <- mapM storeUpdate arsReleases let p = do @@ -140,28 +140,28 @@ instance (MonadBlobStore m) => BlobStorable m AccountReleaseSchedule where loads <- Vector.replicateM len load return $! AccountReleaseSchedule <$> Vector.sequence loads -instance HashableTo TARSV1.AccountReleaseScheduleHashV1 AccountReleaseSchedule where +instance HashableTo TARSV1.AccountReleaseScheduleHashV1 (AccountReleaseSchedule store) where getHash AccountReleaseSchedule{..} = Vector.foldr' (TARSV1.consAccountReleaseScheduleHashV1 . rseReleasesHash) TARSV1.emptyAccountReleaseScheduleHashV1 arsReleases -instance (Monad m) => MHashableTo m TARSV1.AccountReleaseScheduleHashV1 AccountReleaseSchedule +instance (Monad m) => MHashableTo m TARSV1.AccountReleaseScheduleHashV1 (AccountReleaseSchedule store) -- | The empty account release schedule. -emptyAccountReleaseSchedule :: AccountReleaseSchedule +emptyAccountReleaseSchedule :: AccountReleaseSchedule store emptyAccountReleaseSchedule = AccountReleaseSchedule Vector.empty -- | Returns 'True' if the account release schedule contains no releases. -isEmptyAccountReleaseSchedule :: AccountReleaseSchedule -> Bool +isEmptyAccountReleaseSchedule :: AccountReleaseSchedule store -> Bool isEmptyAccountReleaseSchedule = Vector.null . arsReleases -- | Get the timestamp at which the next scheduled release will occur (if any). -nextReleaseTimestamp :: AccountReleaseSchedule -> Maybe Timestamp +nextReleaseTimestamp :: AccountReleaseSchedule store -> Maybe Timestamp nextReleaseTimestamp AccountReleaseSchedule{..} | Vector.length arsReleases == 0 = Nothing | otherwise = Just $! rseNextTimestamp (Vector.head arsReleases) -- | Insert an entry in the account release schedule, preserving the order of -- releases by 'rseSortKey'. -insertEntry :: ReleaseScheduleEntry -> AccountReleaseSchedule -> AccountReleaseSchedule +insertEntry :: ReleaseScheduleEntry store -> AccountReleaseSchedule store -> AccountReleaseSchedule store insertEntry entry AccountReleaseSchedule{..} = AccountReleaseSchedule newReleases where oldLen = Vector.length arsReleases @@ -180,7 +180,7 @@ insertEntry entry AccountReleaseSchedule{..} = AccountReleaseSchedule newRelease -- -- Precondition: The given list of timestamps and amounts MUST NOT be empty and in ascending order -- of timestamps. -addReleases :: (MonadBlobStore m) => ([(Timestamp, Amount)], TransactionHash) -> AccountReleaseSchedule -> m AccountReleaseSchedule +addReleases :: (MonadBlobStore m) => ([(Timestamp, Amount)], TransactionHash) -> AccountReleaseSchedule (MBSStore m) -> m (AccountReleaseSchedule (MBSStore m)) addReleases (rels@((rseNextTimestamp, _) : _), th) ars = do let newReleases = Releases th (Vector.fromList rels) let rseNextReleaseIndex = 0 @@ -193,7 +193,7 @@ addReleases _ _ = error "addReleases: Empty list of timestamps and amounts." -- | Returns the amount that was unlocked, the next timestamp for this account -- (if there is one) and the new account release schedule after removing the -- amounts whose timestamp was less or equal to the given timestamp. -unlockAmountsUntil :: (MonadBlobStore m) => Timestamp -> AccountReleaseSchedule -> m (Amount, Maybe Timestamp, AccountReleaseSchedule) +unlockAmountsUntil :: (MonadBlobStore m) => Timestamp -> AccountReleaseSchedule (MBSStore m) -> m (Amount, Maybe Timestamp, AccountReleaseSchedule (MBSStore m)) unlockAmountsUntil ts ars = do (!relAmt, newRelsList) <- Vector.foldM' updateEntry (0, []) elapsedReleases -- Merge two lists that are assumed ordered by 'rseSortKey' into a @@ -233,7 +233,7 @@ unlockAmountsUntil ts ars = do return $! go rseNextReleaseIndex 0 -- | Migrate an account release schedule for a protocol update. -migrateAccountReleaseSchedule :: (SupportMigration m t) => AccountReleaseSchedule -> t m AccountReleaseSchedule +migrateAccountReleaseSchedule :: (SupportMigration m t) => AccountReleaseSchedule (MBSStore m) -> t m (AccountReleaseSchedule (MBSStore (t m))) migrateAccountReleaseSchedule AccountReleaseSchedule{..} = AccountReleaseSchedule <$!> mapM migrateEntry arsReleases where migrateEntry ReleaseScheduleEntry{..} = do @@ -246,15 +246,15 @@ migrateAccountReleaseSchedule AccountReleaseSchedule{..} = AccountReleaseSchedul migrateAccountReleaseScheduleFromV0 :: forall t m. (SupportMigration m t) => - ARSV0.AccountReleaseSchedule -> - t m AccountReleaseSchedule + ARSV0.AccountReleaseSchedule (MBSStore m) -> + t m (AccountReleaseSchedule (MBSStore (t m))) migrateAccountReleaseScheduleFromV0 schedule = do Vector.foldM' buildSchedule emptyAccountReleaseSchedule (ARSV0._arsValues schedule) where buildSchedule :: - AccountReleaseSchedule -> - Nullable (EagerlyHashedBufferedRef ARSV0.Release, TransactionHash) -> - t m AccountReleaseSchedule + AccountReleaseSchedule (MBSStore (t m)) -> + Nullable (EagerlyHashedBufferedRef (MBSStore m) (ARSV0.Release (MBSStore m)), TransactionHash) -> + t m (AccountReleaseSchedule (MBSStore (t m))) buildSchedule schedule' value = case value of Null -> return schedule' @@ -263,7 +263,7 @@ migrateAccountReleaseScheduleFromV0 schedule = do addReleases (releases, transactionHash) schedule' -- | Convert a transient account release schedule to the persistent one. -makePersistentAccountReleaseSchedule :: (MonadBlobStore m) => TARSV1.AccountReleaseSchedule -> m AccountReleaseSchedule +makePersistentAccountReleaseSchedule :: (MonadBlobStore m) => TARSV1.AccountReleaseSchedule -> m (AccountReleaseSchedule (MBSStore m)) makePersistentAccountReleaseSchedule tars = do AccountReleaseSchedule . Vector.fromList <$> mapM mpEntry (TARSV1.arsReleases tars) where @@ -284,7 +284,7 @@ getAccountReleaseSchedule :: (MonadBlobStore m) => -- | Total locked amount Amount -> - AccountReleaseSchedule -> + AccountReleaseSchedule (MBSStore m) -> m TARSV1.AccountReleaseSchedule getAccountReleaseSchedule arsTotalLockedAmount AccountReleaseSchedule{..} = do releases <- foldrM processEntry [] arsReleases @@ -302,7 +302,7 @@ getAccountReleaseSchedule arsTotalLockedAmount AccountReleaseSchedule{..} = do return $ entry : entries -- | Get the 'AccountReleaseSummary' describing the releases in the 'AccountReleaseSchedule'. -toAccountReleaseSummary :: (MonadBlobStore m) => AccountReleaseSchedule -> m AccountReleaseSummary +toAccountReleaseSummary :: (MonadBlobStore m) => AccountReleaseSchedule (MBSStore m) -> m AccountReleaseSummary toAccountReleaseSummary AccountReleaseSchedule{..} = do (releaseMap, releaseTotal) <- foldlM processEntry (Map.empty, 0) arsReleases let releaseSchedule = makeSR <$> Map.toList releaseMap diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState/Updates.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState/Updates.hs index 7fb2a5b153..0064be5d75 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState/Updates.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState/Updates.hs @@ -42,11 +42,11 @@ import qualified Concordium.Types.UpdateQueues as UQ -- queue will ordinarily be very short (0 or 1 items), and we need to -- update at either end of the queue (which creates problems for a -- linked list representation). -data UpdateQueue e = UpdateQueue +data UpdateQueue store e = UpdateQueue { -- | The next available sequence number for an update. uqNextSequenceNumber :: !UpdateSequenceNumber, -- | Pending updates, in ascending order of effective time. - uqQueue :: !(Seq.Seq (TransactionTime, HashedBufferedRef (StoreSerialized e))) + uqQueue :: !(Seq.Seq (TransactionTime, HashedBufferedRef store (StoreSerialized e))) } -- | See documentation of @migratePersistentBlockState@. @@ -57,8 +57,8 @@ migrateUpdateQueue :: (MHashableTo (t m) H.Hash e2) ) => (e1 -> e2) -> - UpdateQueue e1 -> - t m (UpdateQueue e2) + UpdateQueue (MBSStore m) e1 -> + t m (UpdateQueue (MBSStore (t m)) e2) migrateUpdateQueue f UpdateQueue{..} = do newQueue <- forM uqQueue $ \(tt, r) -> do (tt,) <$> migrateHashedBufferedRef (return . StoreSerialized . f . unStoreSerialized) r @@ -71,8 +71,8 @@ migrateUpdateQueue f UpdateQueue{..} = do -- copy over the next sequence number instance - (MonadBlobStore m, Serialize e) => - BlobStorable m (UpdateQueue e) + (MonadBlobStore m, Serialize e, store ~ MBSStore m) => + BlobStorable m (UpdateQueue store e) where storeUpdate uq@UpdateQueue{..} = do l <- forM uqQueue $ \(t, r) -> do @@ -95,7 +95,7 @@ instance uqQueue <- sequence muqQueue return UpdateQueue{..} -instance (BlobStorable m e, Serialize e, MHashableTo m H.Hash e) => MHashableTo m H.Hash (UpdateQueue e) where +instance (BlobStorable m e, store ~ MBSStore m, Serialize e, MHashableTo m H.Hash e) => MHashableTo m H.Hash (UpdateQueue store e) where getHashM UpdateQueue{..} = do q :: (Seq.Seq (TransactionTime, H.Hash)) <- mapM (\(tt, href) -> (tt,) <$> getHashM href) uqQueue return $! H.hash $ runPut $ do @@ -103,13 +103,13 @@ instance (BlobStorable m e, Serialize e, MHashableTo m H.Hash e) => MHashableTo putLength $ length q mapM_ (\(t, h) -> put t >> put h) q -instance (BlobStorable m e, Serialize e, MHashableTo m H.Hash e) => Cacheable m (UpdateQueue e) where +instance (BlobStorable m e, store ~ MBSStore m, Serialize e, MHashableTo m H.Hash e) => Cacheable m (UpdateQueue store e) where cache uq = do q <- mapM (\(t, h) -> (t,) <$> cache h) (uqQueue uq) return uq{uqQueue = q} -- | Serialize an update queue in V0 format. -putUpdateQueueV0 :: (MonadBlobStore m, MonadPut m, MHashableTo m H.Hash e, Serialize e) => UpdateQueue e -> m () +putUpdateQueueV0 :: (MonadBlobStore m, MonadPut m, MHashableTo m H.Hash e, Serialize e) => UpdateQueue (MBSStore m) e -> m () putUpdateQueueV0 UpdateQueue{..} = do sPut uqNextSequenceNumber forM_ uqQueue $ \(tt, vref) -> do @@ -122,7 +122,7 @@ putUpdateQueueV0 UpdateQueue{..} = do -- | Update queue with no pending updates, and with the minimal next -- sequence number. -emptyUpdateQueue :: UpdateQueue e +emptyUpdateQueue :: UpdateQueue store e emptyUpdateQueue = UpdateQueue { uqNextSequenceNumber = minUpdateSequenceNumber, @@ -130,21 +130,21 @@ emptyUpdateQueue = } -- | Make a persistent update queue from a memory-only queue. -makePersistentUpdateQueue :: (MonadIO m) => UQ.UpdateQueue e -> m (UpdateQueue e) +makePersistentUpdateQueue :: (MonadIO m) => UQ.UpdateQueue e -> m (UpdateQueue (MBSStore m) e) makePersistentUpdateQueue UQ.UpdateQueue{..} = do let uqNextSequenceNumber = _uqNextSequenceNumber uqQueue <- Seq.fromList <$> forM _uqQueue (\(t, e) -> (t,) <$> makeHashedBufferedRef (StoreSerialized e)) return UpdateQueue{..} -- | Convert a persistent update queue to an in-memory one. -makeBasicUpdateQueue :: (MonadBlobStore m, MHashableTo m H.Hash (StoreSerialized e), Serialize e) => UpdateQueue e -> m (UQ.UpdateQueue e) +makeBasicUpdateQueue :: (MonadBlobStore m, MHashableTo m H.Hash (StoreSerialized e), Serialize e) => UpdateQueue (MBSStore m) e -> m (UQ.UpdateQueue e) makeBasicUpdateQueue UpdateQueue{..} = do let _uqNextSequenceNumber = uqNextSequenceNumber _uqQueue <- toList <$> forM uqQueue (\(t, e) -> (t,) . unStoreSerialized <$> refLoad e) return UQ.UpdateQueue{..} -- | Convert a persistent update queue to an in-memory one. -makeBasicUpdateQueueHashed :: (MonadBlobStore m, MHashableTo m H.Hash (StoreSerialized e), Serialize e) => UpdateQueue e -> m (UQ.UpdateQueue (Hashed e)) +makeBasicUpdateQueueHashed :: (MonadBlobStore m, MHashableTo m H.Hash (StoreSerialized e), Serialize e) => UpdateQueue (MBSStore m) e -> m (UQ.UpdateQueue (Hashed e)) makeBasicUpdateQueueHashed UpdateQueue{..} = do let _uqNextSequenceNumber = uqNextSequenceNumber _uqQueue <- @@ -162,11 +162,11 @@ makeBasicUpdateQueueHashed UpdateQueue{..} = do -- Any updates in the queue with later or equal effective times are removed -- from the queue. enqueue :: - (MonadIO m, Reference m ref (UpdateQueue e)) => + (MonadIO m, Reference m store ref (UpdateQueue store e)) => TransactionTime -> e -> - ref (UpdateQueue e) -> - m (ref (UpdateQueue e)) + ref (UpdateQueue store e) -> + m (ref (UpdateQueue store e)) enqueue !t !e q = do UpdateQueue{..} <- refLoad q eref <- makeHashedBufferedRef (StoreSerialized e) @@ -181,9 +181,9 @@ enqueue !t !e q = do -- | Clear all pending updates from a queue. clearQueue :: - (MonadIO m, Reference m ref (UpdateQueue e)) => - ref (UpdateQueue e) -> - m (ref (UpdateQueue e)) + (MonadIO m, Reference m store ref (UpdateQueue store e)) => + ref (UpdateQueue store e) -> + m (ref (UpdateQueue store e)) clearQueue q = do UpdateQueue{..} <- refLoad q refMake $ @@ -194,55 +194,55 @@ clearQueue q = do -- | Load the all pending updates from a queue. loadQueue :: - (Reference m ref (UpdateQueue t), MonadBlobStore m, Serialize t, MHashableTo m H.Hash t) => - ref (UpdateQueue t) -> + (Reference m store ref (UpdateQueue store t), MonadBlobStore m, store ~ MBSStore m, Serialize t, MHashableTo m H.Hash t) => + ref (UpdateQueue store t) -> m [(TransactionTime, t)] loadQueue q = do UpdateQueue{..} <- refLoad q mapM (\(a, b) -> (a,) . unStoreSerialized <$> refLoad b) (toList uqQueue) -- | Update queues for all on-chain update types. -data PendingUpdates (cpv :: ChainParametersVersion) = PendingUpdates +data PendingUpdates store (cpv :: ChainParametersVersion) = PendingUpdates { -- | Updates to the root keys. - pRootKeysUpdateQueue :: !(HashedBufferedRef (UpdateQueue (HigherLevelKeys RootKeysKind))), + pRootKeysUpdateQueue :: !(HashedBufferedRef store (UpdateQueue store (HigherLevelKeys RootKeysKind))), -- | Updates to the level 1 keys. - pLevel1KeysUpdateQueue :: !(HashedBufferedRef (UpdateQueue (HigherLevelKeys Level1KeysKind))), + pLevel1KeysUpdateQueue :: !(HashedBufferedRef store (UpdateQueue store (HigherLevelKeys Level1KeysKind))), -- | Updates to the level 2 keys. - pLevel2KeysUpdateQueue :: !(HashedBufferedRef (UpdateQueue (Authorizations (AuthorizationsVersionFor cpv)))), + pLevel2KeysUpdateQueue :: !(HashedBufferedRef store (UpdateQueue store (Authorizations (AuthorizationsVersionFor cpv)))), -- | Protocol updates. - pProtocolQueue :: !(HashedBufferedRef (UpdateQueue ProtocolUpdate)), + pProtocolQueue :: !(HashedBufferedRef store (UpdateQueue store ProtocolUpdate)), -- | Updates to the election difficulty parameter. - pElectionDifficultyQueue :: !(HashedBufferedRefO 'PTElectionDifficulty cpv (UpdateQueue ElectionDifficulty)), + pElectionDifficultyQueue :: !(HashedBufferedRefO store 'PTElectionDifficulty cpv (UpdateQueue store ElectionDifficulty)), -- | Updates to the euro:energy exchange rate. - pEuroPerEnergyQueue :: !(HashedBufferedRef (UpdateQueue ExchangeRate)), + pEuroPerEnergyQueue :: !(HashedBufferedRef store (UpdateQueue store ExchangeRate)), -- | Updates to the GTU:euro exchange rate. - pMicroGTUPerEuroQueue :: !(HashedBufferedRef (UpdateQueue ExchangeRate)), + pMicroGTUPerEuroQueue :: !(HashedBufferedRef store (UpdateQueue store ExchangeRate)), -- | Updates to the foundation account. - pFoundationAccountQueue :: !(HashedBufferedRef (UpdateQueue AccountIndex)), + pFoundationAccountQueue :: !(HashedBufferedRef store (UpdateQueue store AccountIndex)), -- | Updates to the mint distribution. - pMintDistributionQueue :: !(HashedBufferedRef (UpdateQueue (MintDistribution (MintDistributionVersionFor cpv)))), + pMintDistributionQueue :: !(HashedBufferedRef store (UpdateQueue store (MintDistribution (MintDistributionVersionFor cpv)))), -- | Updates to the transaction fee distribution. - pTransactionFeeDistributionQueue :: !(HashedBufferedRef (UpdateQueue TransactionFeeDistribution)), + pTransactionFeeDistributionQueue :: !(HashedBufferedRef store (UpdateQueue store TransactionFeeDistribution)), -- | Updates to the GAS rewards. - pGASRewardsQueue :: !(HashedBufferedRef (UpdateQueue (GASRewards (GasRewardsVersionFor cpv)))), + pGASRewardsQueue :: !(HashedBufferedRef store (UpdateQueue store (GASRewards (GasRewardsVersionFor cpv)))), -- | Updates to the baker minimum threshold - pPoolParametersQueue :: !(HashedBufferedRef (UpdateQueue (PoolParameters cpv))), + pPoolParametersQueue :: !(HashedBufferedRef store (UpdateQueue store (PoolParameters cpv))), -- | Additions to the set of anonymity revokers - pAddAnonymityRevokerQueue :: !(HashedBufferedRef (UpdateQueue ARS.ArInfo)), + pAddAnonymityRevokerQueue :: !(HashedBufferedRef store (UpdateQueue store ARS.ArInfo)), -- | Additions to the set of identity providers - pAddIdentityProviderQueue :: !(HashedBufferedRef (UpdateQueue IPS.IpInfo)), + pAddIdentityProviderQueue :: !(HashedBufferedRef store (UpdateQueue store IPS.IpInfo)), -- | Updates cooldown parameters - pCooldownParametersQueue :: !(HashedBufferedRefO 'PTCooldownParametersAccessStructure cpv (UpdateQueue (CooldownParameters cpv))), + pCooldownParametersQueue :: !(HashedBufferedRefO store 'PTCooldownParametersAccessStructure cpv (UpdateQueue store (CooldownParameters cpv))), -- | Updates time parameters. - pTimeParametersQueue :: !(HashedBufferedRefO 'PTTimeParameters cpv (UpdateQueue TimeParameters)), + pTimeParametersQueue :: !(HashedBufferedRefO store 'PTTimeParameters cpv (UpdateQueue store TimeParameters)), -- | Updates to the consensus version 2 timeout parameters (CPV2 onwards). - pTimeoutParametersQueue :: !(HashedBufferedRefO 'PTTimeoutParameters cpv (UpdateQueue TimeoutParameters)), + pTimeoutParametersQueue :: !(HashedBufferedRefO store 'PTTimeoutParameters cpv (UpdateQueue store TimeoutParameters)), -- | Minimum block time for consensus version 2 (CPV2 onwards). - pMinBlockTimeQueue :: !(HashedBufferedRefO 'PTMinBlockTime cpv (UpdateQueue Duration)), + pMinBlockTimeQueue :: !(HashedBufferedRefO store 'PTMinBlockTime cpv (UpdateQueue store Duration)), -- | Block energy limit (CPV2 onwards). - pBlockEnergyLimitQueue :: !(HashedBufferedRefO 'PTBlockEnergyLimit cpv (UpdateQueue Energy)), + pBlockEnergyLimitQueue :: !(HashedBufferedRefO store 'PTBlockEnergyLimit cpv (UpdateQueue store Energy)), -- | Finalization committee parameters (CPV2 onwards). - pFinalizationCommitteeParametersQueue :: !(HashedBufferedRefO 'PTFinalizationCommitteeParameters cpv (UpdateQueue FinalizationCommitteeParameters)) + pFinalizationCommitteeParametersQueue :: !(HashedBufferedRefO store 'PTFinalizationCommitteeParameters cpv (UpdateQueue store FinalizationCommitteeParameters)) } -- | See documentation of @migratePersistentBlockState@. @@ -253,8 +253,8 @@ migratePendingUpdates :: SupportMigration m t ) => StateMigrationParameters oldpv pv -> - PendingUpdates (ChainParametersVersionFor oldpv) -> - t m (PendingUpdates (ChainParametersVersionFor pv)) + PendingUpdates (MBSStore m) (ChainParametersVersionFor oldpv) -> + t m (PendingUpdates (MBSStore (t m)) (ChainParametersVersionFor pv)) migratePendingUpdates migration PendingUpdates{..} = withCPVConstraints (chainParametersVersion @(ChainParametersVersionFor oldpv)) $ withCPVConstraints (chainParametersVersion @(ChainParametersVersionFor pv)) $ do newRootKeys <- migrateHashedBufferedRef (migrateUpdateQueue id) pRootKeysUpdateQueue newLevel1Keys <- migrateHashedBufferedRef (migrateUpdateQueue id) pLevel1KeysUpdateQueue @@ -433,8 +433,8 @@ migratePendingUpdates migration PendingUpdates{..} = withCPVConstraints (chainPa } instance - (MonadBlobStore m, IsChainParametersVersion cpv) => - MHashableTo m H.Hash (PendingUpdates cpv) + (MonadBlobStore m, store ~ MBSStore m, IsChainParametersVersion cpv) => + MHashableTo m H.Hash (PendingUpdates store cpv) where getHashM PendingUpdates{..} = withCPVConstraints (chainParametersVersion @cpv) $ do hRootKeysUpdateQueue <- H.hashToByteString <$> getHashM pRootKeysUpdateQueue @@ -484,8 +484,8 @@ instance hashWhenSupported = maybeWhenSupported (return mempty) (fmap H.hashToByteString . getHashM) instance - (MonadBlobStore m, IsChainParametersVersion cpv) => - BlobStorable m (PendingUpdates cpv) + (MonadBlobStore m, store ~ MBSStore m, IsChainParametersVersion cpv) => + BlobStorable m (PendingUpdates store cpv) where storeUpdate PendingUpdates{..} = withCPVConstraints (chainParametersVersion @cpv) $ do (pRKQ, rkQ) <- storeUpdate pRootKeysUpdateQueue @@ -598,8 +598,8 @@ instance return PendingUpdates{..} instance - (MonadBlobStore m, IsChainParametersVersion cpv) => - Cacheable m (PendingUpdates cpv) + (MonadBlobStore m, store ~ MBSStore m, IsChainParametersVersion cpv) => + Cacheable m (PendingUpdates store cpv) where cache PendingUpdates{..} = withCPVConstraints cpv $ @@ -631,10 +631,10 @@ instance emptyPendingUpdates :: forall m cpv. (MonadBlobStore m, IsChainParametersVersion cpv) => - m (PendingUpdates cpv) + m (PendingUpdates (MBSStore m) cpv) emptyPendingUpdates = PendingUpdates <$> e <*> e <*> e <*> e <*> whenSupportedA e <*> e <*> e <*> e <*> e <*> e <*> e <*> e <*> e <*> e <*> whenSupportedA e <*> whenSupportedA e <*> whenSupportedA e <*> whenSupportedA e <*> whenSupportedA e <*> whenSupportedA e where - e :: m (HashedBufferedRef (UpdateQueue a)) + e :: m (HashedBufferedRef (MBSStore m) (UpdateQueue (MBSStore m) a)) e = makeHashedBufferedRef emptyUpdateQueue -- | Construct a persistent 'PendingUpdates' from an in-memory one. @@ -642,7 +642,7 @@ makePersistentPendingUpdates :: forall m cpv. (MonadBlobStore m, IsChainParametersVersion cpv) => UQ.PendingUpdates cpv -> - m (PendingUpdates cpv) + m (PendingUpdates (MBSStore m) cpv) makePersistentPendingUpdates UQ.PendingUpdates{..} = withCPVConstraints (chainParametersVersion @cpv) $ do pRootKeysUpdateQueue <- refMake =<< makePersistentUpdateQueue _pRootKeysUpdateQueue pLevel1KeysUpdateQueue <- refMake =<< makePersistentUpdateQueue _pLevel1KeysUpdateQueue @@ -670,7 +670,7 @@ makePersistentPendingUpdates UQ.PendingUpdates{..} = withCPVConstraints (chainPa makeBasicPendingUpdates :: forall m cpv. (MonadBlobStore m, IsChainParametersVersion cpv) => - PendingUpdates cpv -> + PendingUpdates (MBSStore m) cpv -> m (UQ.PendingUpdates cpv) makeBasicPendingUpdates PendingUpdates{..} = withCPVConstraints (chainParametersVersion @cpv) $ do _pRootKeysUpdateQueue <- makeBasicUpdateQueue =<< refLoad pRootKeysUpdateQueue @@ -696,15 +696,15 @@ makeBasicPendingUpdates PendingUpdates{..} = withCPVConstraints (chainParameters return UQ.PendingUpdates{..} -- | Current state of updatable parameters and update queues. -data Updates' (cpv :: ChainParametersVersion) = Updates +data Updates' store (cpv :: ChainParametersVersion) = Updates { -- | Current update authorizations. - currentKeyCollection :: !(HashedBufferedRef (StoreSerialized (UpdateKeysCollection (AuthorizationsVersionFor cpv)))), + currentKeyCollection :: !(HashedBufferedRef store (StoreSerialized (UpdateKeysCollection (AuthorizationsVersionFor cpv)))), -- | Current protocol update. - currentProtocolUpdate :: !(Nullable (HashedBufferedRef (StoreSerialized ProtocolUpdate))), + currentProtocolUpdate :: !(Nullable (HashedBufferedRef store (StoreSerialized ProtocolUpdate))), -- | Current chain parameters. - currentParameters :: !(HashedBufferedRef (StoreSerialized (ChainParameters' cpv))), + currentParameters :: !(HashedBufferedRef store (StoreSerialized (ChainParameters' cpv))), -- | Pending updates. - pendingUpdates :: !(PendingUpdates cpv) + pendingUpdates :: !(PendingUpdates store cpv) } -- | See documentation of @migratePersistentBlockState@. @@ -715,8 +715,8 @@ migrateUpdates :: SupportMigration m t ) => StateMigrationParameters oldpv pv -> - Updates oldpv -> - t m (Updates pv) + Updates (MBSStore m) oldpv -> + t m (Updates (MBSStore (t m)) pv) migrateUpdates migration Updates{..} = do newPendingUpdates <- migratePendingUpdates migration pendingUpdates let migrateKeysCollection UpdateKeysCollection{..} = @@ -742,9 +742,9 @@ migrateUpdates migration Updates{..} = do currentProtocolUpdate = Null } -type Updates (pv :: ProtocolVersion) = Updates' (ChainParametersVersionFor pv) +type Updates store (pv :: ProtocolVersion) = Updates' store (ChainParametersVersionFor pv) -instance (MonadBlobStore m, IsChainParametersVersion cpv) => MHashableTo m H.Hash (Updates' cpv) where +instance (MonadBlobStore m, store ~ MBSStore m, IsChainParametersVersion cpv) => MHashableTo m H.Hash (Updates' store cpv) where getHashM Updates{..} = do hCA <- withIsAuthorizationsVersionFor (chainParametersVersion @cpv) $ @@ -762,8 +762,8 @@ instance (MonadBlobStore m, IsChainParametersVersion cpv) => MHashableTo m H.Has <> H.hashToByteString hPU instance - (MonadBlobStore m, IsChainParametersVersion cpv) => - BlobStorable m (Updates' cpv) + (MonadBlobStore m, store ~ MBSStore m, IsChainParametersVersion cpv) => + BlobStorable m (Updates' store cpv) where storeUpdate Updates{..} = do (pKC, kC) <- @@ -794,7 +794,7 @@ instance pendingUpdates <- mPU return Updates{..} -instance (MonadBlobStore m, IsChainParametersVersion cpv) => Cacheable m (Updates' cpv) where +instance (MonadBlobStore m, store ~ MBSStore m, IsChainParametersVersion cpv) => Cacheable m (Updates' store cpv) where cache Updates{..} = Updates <$> withIsAuthorizationsVersionFor (chainParametersVersion @cpv) (cache currentKeyCollection) @@ -808,7 +808,7 @@ initialUpdates :: (MonadBlobStore m, IsChainParametersVersion cpv) => UpdateKeysCollection (AuthorizationsVersionFor cpv) -> ChainParameters' cpv -> - m (Updates' cpv) + m (Updates' (MBSStore m) cpv) initialUpdates initialKeyCollection chainParams = do currentKeyCollection <- makeHashedBufferedRef (StoreSerialized initialKeyCollection) let currentProtocolUpdate = Null @@ -821,7 +821,7 @@ makePersistentUpdates :: forall m cpv. (MonadBlobStore m, IsChainParametersVersion cpv) => UQ.Updates' cpv -> - m (Updates' cpv) + m (Updates' (MBSStore m) cpv) makePersistentUpdates UQ.Updates{..} = withIsAuthorizationsVersionFor (chainParametersVersion @cpv) $ do currentKeyCollection <- refMake (StoreSerialized (_unhashed _currentKeyCollection)) currentProtocolUpdate <- case _currentProtocolUpdate of @@ -835,7 +835,7 @@ makePersistentUpdates UQ.Updates{..} = withIsAuthorizationsVersionFor (chainPara makeBasicUpdates :: forall m cpv. (MonadBlobStore m, IsChainParametersVersion cpv) => - (Updates' cpv) -> + Updates' (MBSStore m) cpv -> m (UQ.Updates' cpv) makeBasicUpdates Updates{..} = withIsAuthorizationsVersionFor (chainParametersVersion @cpv) $ do hKC <- getHashM currentKeyCollection @@ -855,11 +855,11 @@ makeBasicUpdates Updates{..} = withIsAuthorizationsVersionFor (chainParametersVe processValueUpdates :: (MonadBlobStore m, Serialize v, MHashableTo m H.Hash v) => Timestamp -> - UpdateQueue v -> + UpdateQueue (MBSStore m) v -> -- | No update continuation m res -> -- | Update continuation - (HashedBufferedRef (StoreSerialized v) -> UpdateQueue v -> Map.Map TransactionTime v -> m res) -> + (HashedBufferedRef (MBSStore m) (StoreSerialized v) -> UpdateQueue (MBSStore m) v -> Map.Map TransactionTime v -> m res) -> m res processValueUpdates t uq noUpdate doUpdate = case ql of Seq.Empty -> noUpdate @@ -877,8 +877,8 @@ processRootKeysUpdates :: forall m cpv. (MonadBlobStore m, IsChainParametersVersion cpv) => Timestamp -> - BufferedRef (Updates' cpv) -> - m (Map.Map TransactionTime (UpdateValue cpv), BufferedRef (Updates' cpv)) + BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv) -> + m (Map.Map TransactionTime (UpdateValue cpv), BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv)) processRootKeysUpdates t bu = withIsAuthorizationsVersionFor (chainParametersVersion @cpv) $ do u@Updates{..} <- refLoad bu rootKeysQueue <- refLoad (pRootKeysUpdateQueue pendingUpdates) @@ -899,8 +899,8 @@ processLevel1KeysUpdates :: forall m cpv. (MonadBlobStore m, IsChainParametersVersion cpv) => Timestamp -> - BufferedRef (Updates' cpv) -> - m (Map.Map TransactionTime (UpdateValue cpv), BufferedRef (Updates' cpv)) + BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv) -> + m (Map.Map TransactionTime (UpdateValue cpv), BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv)) processLevel1KeysUpdates t bu = withIsAuthorizationsVersionFor (chainParametersVersion @cpv) $ do u@Updates{..} <- refLoad bu level1KeysQueue <- refLoad (pLevel1KeysUpdateQueue pendingUpdates) @@ -921,8 +921,8 @@ processLevel2KeysUpdates :: forall m cpv. (MonadBlobStore m, IsChainParametersVersion cpv) => Timestamp -> - BufferedRef (Updates' cpv) -> - m (Map.Map TransactionTime (UpdateValue cpv), BufferedRef (Updates' cpv)) + BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv) -> + m (Map.Map TransactionTime (UpdateValue cpv), BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv)) processLevel2KeysUpdates t bu = withIsAuthorizationsVersionFor (chainParametersVersion @cpv) $ do u@Updates{..} <- refLoad bu level2KeysQueue <- refLoad (pLevel2KeysUpdateQueue pendingUpdates) @@ -942,8 +942,8 @@ processLevel2KeysUpdates t bu = withIsAuthorizationsVersionFor (chainParametersV processElectionDifficultyUpdates :: (MonadBlobStore m, IsChainParametersVersion cpv) => Timestamp -> - BufferedRef (Updates' cpv) -> - m (Map.Map TransactionTime (UpdateValue cpv), BufferedRef (Updates' cpv)) + BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv) -> + m (Map.Map TransactionTime (UpdateValue cpv), BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv)) processElectionDifficultyUpdates t bu = do u@Updates{..} <- refLoad bu case pElectionDifficultyQueue pendingUpdates of @@ -968,8 +968,8 @@ processElectionDifficultyUpdates t bu = do processEuroPerEnergyUpdates :: (MonadBlobStore m, IsChainParametersVersion cpv) => Timestamp -> - BufferedRef (Updates' cpv) -> - m (Map.Map TransactionTime (UpdateValue cpv), BufferedRef (Updates' cpv)) + BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv) -> + m (Map.Map TransactionTime (UpdateValue cpv), BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv)) processEuroPerEnergyUpdates t bu = do u@Updates{..} <- refLoad bu oldQ <- refLoad (pEuroPerEnergyQueue pendingUpdates) @@ -989,8 +989,8 @@ processEuroPerEnergyUpdates t bu = do processMicroGTUPerEuroUpdates :: (MonadBlobStore m, IsChainParametersVersion cpv) => Timestamp -> - BufferedRef (Updates' cpv) -> - m (Map.Map TransactionTime (UpdateValue cpv), BufferedRef (Updates' cpv)) + BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv) -> + m (Map.Map TransactionTime (UpdateValue cpv), BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv)) processMicroGTUPerEuroUpdates t bu = do u@Updates{..} <- refLoad bu oldQ <- refLoad (pMicroGTUPerEuroQueue pendingUpdates) @@ -1009,8 +1009,8 @@ processMicroGTUPerEuroUpdates t bu = do processFoundationAccountUpdates :: (MonadBlobStore m, IsChainParametersVersion cpv) => Timestamp -> - BufferedRef (Updates' cpv) -> - m (Map.Map TransactionTime (UpdateValue cpv), BufferedRef (Updates' cpv)) + BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv) -> + m (Map.Map TransactionTime (UpdateValue cpv), BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv)) processFoundationAccountUpdates t bu = do u@Updates{..} <- refLoad bu oldQ <- refLoad (pFoundationAccountQueue pendingUpdates) @@ -1030,8 +1030,8 @@ processMintDistributionUpdates :: forall m cpv. (MonadBlobStore m, IsChainParametersVersion cpv) => Timestamp -> - BufferedRef (Updates' cpv) -> - m (Map.Map TransactionTime (UpdateValue cpv), BufferedRef (Updates' cpv)) + BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv) -> + m (Map.Map TransactionTime (UpdateValue cpv), BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv)) processMintDistributionUpdates t bu = withIsMintDistributionVersionFor (chainParametersVersion @cpv) $ do u@Updates{..} <- refLoad bu oldQ <- refLoad (pMintDistributionQueue pendingUpdates) @@ -1050,8 +1050,8 @@ processMintDistributionUpdates t bu = withIsMintDistributionVersionFor (chainPar processTransactionFeeDistributionUpdates :: (MonadBlobStore m, IsChainParametersVersion cpv) => Timestamp -> - BufferedRef (Updates' cpv) -> - m (Map.Map TransactionTime (UpdateValue cpv), BufferedRef (Updates' cpv)) + BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv) -> + m (Map.Map TransactionTime (UpdateValue cpv), BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv)) processTransactionFeeDistributionUpdates t bu = do u@Updates{..} <- refLoad bu oldQ <- refLoad (pTransactionFeeDistributionQueue pendingUpdates) @@ -1071,8 +1071,8 @@ processGASRewardsUpdates :: forall m cpv. (MonadBlobStore m, IsChainParametersVersion cpv) => Timestamp -> - BufferedRef (Updates' cpv) -> - m (Map.Map TransactionTime (UpdateValue cpv), BufferedRef (Updates' cpv)) + BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv) -> + m (Map.Map TransactionTime (UpdateValue cpv), BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv)) processGASRewardsUpdates t bu = withIsGASRewardsVersionFor (chainParametersVersion @cpv) $ do u@Updates{..} <- refLoad bu oldQ <- refLoad (pGASRewardsQueue pendingUpdates) @@ -1092,8 +1092,8 @@ processPoolParamatersUpdates :: forall m cpv. (MonadBlobStore m, IsChainParametersVersion cpv) => Timestamp -> - BufferedRef (Updates' cpv) -> - m (Map.Map TransactionTime (UpdateValue cpv), BufferedRef (Updates' cpv)) + BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv) -> + m (Map.Map TransactionTime (UpdateValue cpv), BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv)) processPoolParamatersUpdates t bu = withIsPoolParametersVersionFor (chainParametersVersion @cpv) $ do u@Updates{..} <- refLoad bu oldQ <- refLoad (pPoolParametersQueue pendingUpdates) @@ -1114,8 +1114,8 @@ processCooldownParametersUpdates :: forall m cpv. (MonadBlobStore m, IsChainParametersVersion cpv) => Timestamp -> - BufferedRef (Updates' cpv) -> - m (Map.Map TransactionTime (UpdateValue cpv), BufferedRef (Updates' cpv)) + BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv) -> + m (Map.Map TransactionTime (UpdateValue cpv), BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv)) processCooldownParametersUpdates t bu = do u@Updates{..} <- refLoad bu case pCooldownParametersQueue pendingUpdates of @@ -1138,8 +1138,8 @@ processCooldownParametersUpdates t bu = do processTimeParametersUpdates :: (MonadBlobStore m, IsChainParametersVersion cpv) => Timestamp -> - BufferedRef (Updates' cpv) -> - m (Map.Map TransactionTime (UpdateValue cpv), BufferedRef (Updates' cpv)) + BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv) -> + m (Map.Map TransactionTime (UpdateValue cpv), BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv)) processTimeParametersUpdates t bu = do u@Updates{..} <- refLoad bu case pTimeParametersQueue pendingUpdates of @@ -1166,8 +1166,8 @@ processTimeoutParametersUpdates :: forall m cpv. (MonadBlobStore m, IsChainParametersVersion cpv) => Timestamp -> - BufferedRef (Updates' cpv) -> - m (Map.Map TransactionTime (UpdateValue cpv), BufferedRef (Updates' cpv)) + BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv) -> + m (Map.Map TransactionTime (UpdateValue cpv), BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv)) processTimeoutParametersUpdates t bu = do u@Updates{..} <- refLoad bu case pTimeoutParametersQueue pendingUpdates of @@ -1196,8 +1196,8 @@ processMinBlockTimeUpdates :: forall m cpv. (MonadBlobStore m, IsChainParametersVersion cpv) => Timestamp -> - BufferedRef (Updates' cpv) -> - m (Map.Map TransactionTime (UpdateValue cpv), BufferedRef (Updates' cpv)) + BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv) -> + m (Map.Map TransactionTime (UpdateValue cpv), BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv)) processMinBlockTimeUpdates t bu = do u@Updates{..} <- refLoad bu case pMinBlockTimeQueue pendingUpdates of @@ -1226,8 +1226,8 @@ processBlockEnergyLimitUpdates :: forall m cpv. (MonadBlobStore m, IsChainParametersVersion cpv) => Timestamp -> - BufferedRef (Updates' cpv) -> - m (Map.Map TransactionTime (UpdateValue cpv), BufferedRef (Updates' cpv)) + BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv) -> + m (Map.Map TransactionTime (UpdateValue cpv), BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv)) processBlockEnergyLimitUpdates t bu = do u@Updates{..} <- refLoad bu case pBlockEnergyLimitQueue pendingUpdates of @@ -1256,8 +1256,8 @@ processFinalizationCommitteeParametersUpdates :: forall m cpv. (MonadBlobStore m, IsChainParametersVersion cpv) => Timestamp -> - BufferedRef (Updates' cpv) -> - m (Map.Map TransactionTime (UpdateValue cpv), BufferedRef (Updates' cpv)) + BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv) -> + m (Map.Map TransactionTime (UpdateValue cpv), BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv)) processFinalizationCommitteeParametersUpdates t bu = do u@Updates{..} <- refLoad bu case pFinalizationCommitteeParametersQueue pendingUpdates of @@ -1285,9 +1285,9 @@ processFinalizationCommitteeParametersUpdates t bu = do processAddAnonymityRevokerUpdates :: (MonadBlobStore m, IsChainParametersVersion cpv) => Timestamp -> - BufferedRef (Updates' cpv) -> - HashedBufferedRef ARS.AnonymityRevokers -> - m (Map.Map TransactionTime (UpdateValue cpv), BufferedRef (Updates' cpv), HashedBufferedRef ARS.AnonymityRevokers) + BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv) -> + HashedBufferedRef (MBSStore m) ARS.AnonymityRevokers -> + m (Map.Map TransactionTime (UpdateValue cpv), BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv), HashedBufferedRef (MBSStore m) ARS.AnonymityRevokers) processAddAnonymityRevokerUpdates t bu hbar = do u@Updates{..} <- refLoad bu oldQ <- refLoad (pAddAnonymityRevokerQueue pendingUpdates) @@ -1313,9 +1313,9 @@ processAddAnonymityRevokerUpdates t bu hbar = do processAddIdentityProviderUpdates :: (MonadBlobStore m, IsChainParametersVersion cpv) => Timestamp -> - BufferedRef (Updates' cpv) -> - HashedBufferedRef IPS.IdentityProviders -> - m (Map.Map TransactionTime (UpdateValue cpv), BufferedRef (Updates' cpv), HashedBufferedRef IPS.IdentityProviders) + BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv) -> + HashedBufferedRef (MBSStore m) IPS.IdentityProviders -> + m (Map.Map TransactionTime (UpdateValue cpv), BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv), HashedBufferedRef (MBSStore m) IPS.IdentityProviders) processAddIdentityProviderUpdates t bu hbip = do u@Updates{..} <- refLoad bu oldQ <- refLoad (pAddIdentityProviderQueue pendingUpdates) @@ -1339,9 +1339,9 @@ processAddIdentityProviderUpdates t bu hbip = do -- | Used for adding new IPs and ARs. -- Ensuring that new IPs/ARs have unique ids is difficult when enqueueing. -- Instead, it is handled here by ignoring updates with duplicate IPs/ARs. --- It also accumulates the actual changes that occured. +-- It also accumulates the actual changes that occurred. addAndAccumNonduplicateUpdates :: - (Foldable f, Reference m ref (StoreSerialized v), Ord k) => + (Foldable f, Reference m store ref (StoreSerialized v), Ord k) => -- | The existing IPs / ARs. Map.Map k v -> -- | Getter for the key field. @@ -1365,13 +1365,11 @@ addAndAccumNonduplicateUpdates oldMap getKey toUV = foldM go (Map.empty, oldMap) -- | Process the protocol update queue. Unlike other queues, once a protocol update occurs, it is not -- overridden by later ones. --- FIXME: We may just want to keep unused protocol updates in the queue, even if their timestamps have --- elapsed. processProtocolUpdates :: (MonadBlobStore m, IsChainParametersVersion cpv) => Timestamp -> - BufferedRef (Updates' cpv) -> - m (Map.Map TransactionTime (UpdateValue cpv), BufferedRef (Updates' cpv)) + BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv) -> + m (Map.Map TransactionTime (UpdateValue cpv), BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv)) processProtocolUpdates t bu = do u@Updates{..} <- refLoad bu protQueue <- refLoad (pProtocolQueue pendingUpdates) @@ -1399,8 +1397,8 @@ processProtocolUpdates t bu = do v <- UVProtocol . unStoreSerialized <$> refLoad r return $! Map.insert tt v m -type UpdatesWithARsAndIPs (cpv :: ChainParametersVersion) = - (BufferedRef (Updates' cpv), HashedBufferedRef ARS.AnonymityRevokers, HashedBufferedRef IPS.IdentityProviders) +type UpdatesWithARsAndIPs store (cpv :: ChainParametersVersion) = + (BufferedRef store (Updates' store cpv), HashedBufferedRef store ARS.AnonymityRevokers, HashedBufferedRef store IPS.IdentityProviders) -- | Process all update queues. This returns a list of the updates that occurred, with their times, -- ordered by the time. @@ -1408,8 +1406,8 @@ processUpdateQueues :: forall m cpv. (MonadBlobStore m, IsChainParametersVersion cpv) => Timestamp -> - UpdatesWithARsAndIPs cpv -> - m ([(TransactionTime, UpdateValue cpv)], UpdatesWithARsAndIPs cpv) + UpdatesWithARsAndIPs (MBSStore m) cpv -> + m ([(TransactionTime, UpdateValue cpv)], UpdatesWithARsAndIPs (MBSStore m) cpv) processUpdateQueues t (u0, ars, ips) = do (ms, u1) <- combine @@ -1450,8 +1448,8 @@ processUpdateQueues t (u0, ars, ips) = do -- The return value is the final state of updates, and the list of -- updates. The list is in **reverse** order of the input list. combine :: - [BufferedRef (Updates' cpv) -> m (r, BufferedRef (Updates' cpv))] -> - m ([r], BufferedRef (Updates' cpv)) + [BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv) -> m (r, BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv))] -> + m ([r], BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv)) combine = foldM ( \(ms, updates) action -> do @@ -1475,7 +1473,7 @@ processUpdateQueues t (u0, ars, ips) = do -- on a current 'Updates'. futureElectionDifficulty :: (MonadBlobStore m, IsChainParametersVersion cpv, IsSupported 'PTElectionDifficulty cpv ~ 'True, ConsensusParametersVersionFor cpv ~ 'ConsensusParametersVersion0) => - BufferedRef (Updates' cpv) -> + BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv) -> Timestamp -> m ElectionDifficulty futureElectionDifficulty uref ts = do @@ -1490,7 +1488,7 @@ futureElectionDifficulty uref ts = do -- a list of pending future protocol updates. protocolUpdateStatus :: (MonadBlobStore m, IsChainParametersVersion cpv) => - BufferedRef (Updates' cpv) -> + BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv) -> m UQ.ProtocolUpdateStatus protocolUpdateStatus uref = do Updates{..} <- refLoad uref @@ -1503,7 +1501,7 @@ protocolUpdateStatus uref = do -- | Get whether a protocol update is effective isProtocolUpdateEffective :: (MonadBlobStore m, IsChainParametersVersion cpv) => - BufferedRef (Updates' cpv) -> + BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv) -> m Bool isProtocolUpdateEffective uref = do Updates{..} <- refLoad uref @@ -1515,7 +1513,7 @@ isProtocolUpdateEffective uref = do lookupNextUpdateSequenceNumber :: forall m cpv. (MonadBlobStore m, IsChainParametersVersion cpv) => - BufferedRef (Updates' cpv) -> + BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv) -> UpdateType -> m UpdateSequenceNumber lookupNextUpdateSequenceNumber uref uty = withCPVConstraints (chainParametersVersion @cpv) $ do @@ -1576,8 +1574,8 @@ enqueueUpdate :: (MonadBlobStore m, IsChainParametersVersion cpv) => TransactionTime -> UpdateValue cpv -> - BufferedRef (Updates' cpv) -> - m (BufferedRef (Updates' cpv)) + BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv) -> + m (BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv)) enqueueUpdate effectiveTime payload uref = withCPVConstraints (chainParametersVersion @cpv) $ do u@Updates{pendingUpdates = p@PendingUpdates{..}} <- refLoad uref newPendingUpdates <- case payload of @@ -1628,8 +1626,8 @@ enqueueUpdate effectiveTime payload uref = withCPVConstraints (chainParametersVe overwriteElectionDifficulty :: (MonadBlobStore m, IsChainParametersVersion cpv, IsSupported 'PTElectionDifficulty cpv ~ 'True, ConsensusParametersVersionFor cpv ~ 'ConsensusParametersVersion0) => ElectionDifficulty -> - BufferedRef (Updates' cpv) -> - m (BufferedRef (Updates' cpv)) + BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv) -> + m (BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv)) overwriteElectionDifficulty newDifficulty uref = do u@Updates{pendingUpdates = p@PendingUpdates{..}, ..} <- refLoad uref StoreSerialized cp <- refLoad currentParameters @@ -1641,8 +1639,8 @@ overwriteElectionDifficulty newDifficulty uref = do -- the queue. clearProtocolUpdate :: (MonadBlobStore m, IsChainParametersVersion cpv) => - BufferedRef (Updates' cpv) -> - m (BufferedRef (Updates' cpv)) + BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv) -> + m (BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv)) clearProtocolUpdate uref = do u@Updates{pendingUpdates = p@PendingUpdates{..}} <- refLoad uref newPendingUpdates <- clearQueue pProtocolQueue <&> \newQ -> p{pProtocolQueue = newQ} @@ -1651,7 +1649,7 @@ clearProtocolUpdate uref = do -- | Get the current exchange rates, which are the Euro per NRG, micro CCD per Euro and the energy rate. lookupExchangeRates :: (MonadBlobStore m, IsChainParametersVersion cpv) => - BufferedRef (Updates' cpv) -> + BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv) -> m ExchangeRates lookupExchangeRates uref = do Updates{..} <- refLoad uref @@ -1661,7 +1659,7 @@ lookupExchangeRates uref = do -- | Look up the current chain parameters. lookupCurrentParameters :: (MonadBlobStore m, IsChainParametersVersion cpv) => - BufferedRef (Updates' cpv) -> + BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv) -> m (ChainParameters' cpv) lookupCurrentParameters uref = do Updates{..} <- refLoad uref @@ -1670,7 +1668,7 @@ lookupCurrentParameters uref = do -- | Look up the pending changes to the time parameters. lookupPendingTimeParameters :: (MonadBlobStore m, IsChainParametersVersion cpv) => - BufferedRef (Updates' cpv) -> + BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv) -> m [(TransactionTime, TimeParameters)] lookupPendingTimeParameters uref = do Updates{..} <- refLoad uref @@ -1682,7 +1680,7 @@ lookupPendingTimeParameters uref = do lookupPendingPoolParameters :: forall m cpv. (MonadBlobStore m, IsChainParametersVersion cpv) => - BufferedRef (Updates' cpv) -> + BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv) -> m [(TransactionTime, PoolParameters cpv)] lookupPendingPoolParameters uref = do Updates{..} <- refLoad uref diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Cache.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Cache.hs index 880addf076..36cbf59e17 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Cache.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Cache.hs @@ -1,6 +1,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} module Concordium.GlobalState.Persistent.Cache where @@ -49,7 +50,7 @@ instance (MonadCache c m) => MonadCache c (ExceptT e m) where getCache = lift getCache {-# INLINE getCache #-} -instance (HasCache c r, MonadIO m) => MonadCache c (BlobStoreT r m) where +instance (HasCache c r, MonadIO m) => MonadCache c (BlobStoreT store r m) where getCache = asks projectCache {-# INLINE getCache #-} @@ -99,11 +100,11 @@ instance HasCache c (CacheContext c) where -- | A null cache that does not store any values. -- That is, all lookups are cache misses. -data NullCache (v :: Type) = NullCache +data NullCache store (v :: Type) = NullCache -instance Cache (NullCache v) where - type CacheKey (NullCache v) = BlobRef v - type CacheValue (NullCache v) = v +instance Cache (NullCache store v) where + type CacheKey (NullCache store v) = BlobRef store v + type CacheValue (NullCache store v) = v newCache = newNullCache collapseCache _ = return () @@ -112,7 +113,7 @@ instance Cache (NullCache v) where getCacheSize _ = return 0 -- | Construct a new 'NullCache'. The size parameter is ignored. -newNullCache :: Int -> IO (NullCache v) +newNullCache :: Int -> IO (NullCache store v) newNullCache _ = pure NullCache -- | First-in, first-out cache, with entries keyed by 'BlobRef's. @@ -132,30 +133,30 @@ data FIFOCache' v = FIFOCache' } -- | Convert a 'BlobRef' to an 'Int'. -cacheEntry :: BlobRef a -> Int +cacheEntry :: BlobRef store a -> Int cacheEntry = fromIntegral . theBlobRef -- | A cache entry that is a non-valid 'BlobRef'. nullCacheEntry :: Int -nullCacheEntry = cacheEntry (refNull :: BlobRef ()) +nullCacheEntry = cacheEntry (refNull :: BlobRef store ()) -- | First-in, first-out cache, with entries keyed by 'BlobRefs's. -- 'refNull' is considered an invalid key, and should not be inserted in the cache. -newtype FIFOCache v = FIFOCache {theFIFOCache :: MVar (FIFOCache' v)} +newtype FIFOCache store v = FIFOCache {theFIFOCache :: MVar (FIFOCache' v)} -instance Cache (FIFOCache v) where - type CacheKey (FIFOCache v) = BlobRef v - type CacheValue (FIFOCache v) = v +instance Cache (FIFOCache store v) where + type CacheKey (FIFOCache store v) = BlobRef store v + type CacheValue (FIFOCache store v) = v newCache = newFIFOCache collapseCache _ = do - FIFOCache cacheRef <- getCache + FIFOCache cacheRef <- getCache @(FIFOCache store v) liftIO $ do (cache :: FIFOCache' v) <- emptyFIFOCache' 0 void $ swapMVar cacheRef $! cache putCachedValue _ key val = do let intKey = cacheEntry key - FIFOCache cacheRef <- getCache + FIFOCache cacheRef <- getCache @(FIFOCache store v) liftIO $! do cache <- takeMVar cacheRef case IntMap.lookup intKey (keyMap cache) of @@ -179,14 +180,14 @@ instance Cache (FIFOCache v) where return val lookupCachedValue _ key = do - FIFOCache cacheRef <- getCache + FIFOCache cacheRef <- getCache @(FIFOCache store v) -- This should be OK as we are just accessing the keyMap, so we can read from a snapshot. -- We need to be sure not to retain references after we are done. cache <- liftIO $! readMVar cacheRef return $! IntMap.lookup (cacheEntry key) (keyMap cache) getCacheSize _ = do - FIFOCache cacheRef :: FIFOCache v <- getCache + FIFOCache cacheRef :: FIFOCache store v <- getCache cache <- liftIO $! readMVar cacheRef return $! IntMap.size (keyMap cache) @@ -205,7 +206,7 @@ emptyFIFOCache' size' = do -- | Construct a FIFO cache of at least the specified size. -- If the size is less than 1, a cache of size 1 will be created instead. -newFIFOCache :: Int -> IO (FIFOCache v) +newFIFOCache :: Int -> IO (FIFOCache store v) newFIFOCache size = do cache <- emptyFIFOCache' size FIFOCache <$> newMVar cache diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/CachedRef.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/CachedRef.hs index 537fd96cd8..212ad72b2e 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/CachedRef.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/CachedRef.hs @@ -22,9 +22,9 @@ import Concordium.GlobalState.Persistent.Cache -- * 'CachedRef' -- | A value that is either stored on disk as a 'BlobRef' or in memory only. -data MaybeMem a +data MaybeMem store a = -- | A value stored on disk as a 'BlobRef' - Disk !(BlobRef a) + Disk !(BlobRef store a) | -- | A value held directly in memory Mem !a @@ -37,16 +37,17 @@ data MaybeMem a -- between block states, which can happen if finalization is lagging the head of the chain. -- The IORef is shared among all copies of the reference, which ensures that it is not unnecessarily -- held in memory and is not written to disk in duplicate. -newtype CachedRef c a = CachedRef {crIORef :: IORef (MaybeMem a)} +newtype CachedRef store c a = CachedRef {crIORef :: IORef (MaybeMem store a)} instance ( MonadCache c m, DirectBlobStorable m a, + store ~ MBSStore m, Cache c, - CacheKey c ~ BlobRef a, + CacheKey c ~ BlobRef store a, CacheValue c ~ a ) => - Reference m (CachedRef c) a + Reference m store (CachedRef store c) a where refFlush cr@(CachedRef ioref) = do mbr <- liftIO $ readIORef ioref @@ -92,11 +93,12 @@ instance instance ( MonadCache c m, DirectBlobStorable m a, + store ~ MBSStore m, Cache c, - CacheKey c ~ BlobRef a, + CacheKey c ~ BlobRef store a, CacheValue c ~ a ) => - BlobStorable m (CachedRef c a) + BlobStorable m (CachedRef store c a) where storeUpdate c = do (c', ref) <- refFlush c @@ -112,47 +114,49 @@ instance instance ( MonadCache c m, DirectBlobStorable m a, + store ~ MBSStore m, Cache c, - CacheKey c ~ BlobRef a, + CacheKey c ~ BlobRef store a, CacheValue c ~ a, MHashableTo m h a ) => - MHashableTo m h (CachedRef c a) + MHashableTo m h (CachedRef store c a) where getHashM ref = getHashM =<< refLoad ref -instance (Show a) => Show (CachedRef c a) where +instance (Show a) => Show (CachedRef store c a) where show _ = "" -- | We do nothing to cache a 'CachedRef'. Since 'cache' is generally used to cache the entire -- global state, it is generally undesirable to load every 'CachedRef' into the cache, as this -- can result in evictions and wasted effort if the cache size is insufficient. -instance (Applicative m) => Cacheable m (CachedRef c a) where +instance (Applicative m) => Cacheable m (CachedRef store c a) where cache = pure -- * 'LazilyHashedCachedRef' -- | A 'CachedRef' with a hash that is computed when first demanded (via 'getHashM'), or when the -- reference is cached (via 'refCache' or 'cache'). -data LazilyHashedCachedRef' h c a = LazilyHashedCachedRef - { lhCachedRef :: !(CachedRef c a), +data LazilyHashedCachedRef' h store c a = LazilyHashedCachedRef + { lhCachedRef :: !(CachedRef store c a), lhHash :: !(IORef (Nullable h)) } type LazilyHashedCachedRef = LazilyHashedCachedRef' H.Hash -instance Show (LazilyHashedCachedRef' h c a) where +instance Show (LazilyHashedCachedRef' h store c a) where show _ = "" instance ( MonadCache c m, DirectBlobStorable m a, + store ~ MBSStore m, Cache c, - CacheKey c ~ BlobRef a, + CacheKey c ~ BlobRef store a, CacheValue c ~ a, MHashableTo m h a ) => - MHashableTo m h (LazilyHashedCachedRef' h c a) + MHashableTo m h (LazilyHashedCachedRef' h store c a) where getHashM LazilyHashedCachedRef{..} = liftIO (readIORef lhHash) >>= \case @@ -165,12 +169,13 @@ instance instance ( MonadCache c m, DirectBlobStorable m a, + store ~ MBSStore m, Cache c, - CacheKey c ~ BlobRef a, + CacheKey c ~ BlobRef store a, CacheValue c ~ a, MHashableTo m h a ) => - Reference m (LazilyHashedCachedRef' h c) a + Reference m store (LazilyHashedCachedRef' h store c) a where refFlush ref = do (cr, r) <- refFlush $ lhCachedRef ref @@ -197,7 +202,7 @@ instance return LazilyHashedCachedRef{lhCachedRef = cr, lhHash = lhHash ref} -- | Construct a 'LazilyHashedCachedRef'' given the value and hash. -makeLazilyHashedCachedRef :: (MonadIO m) => a -> h -> m (LazilyHashedCachedRef' h c a) +makeLazilyHashedCachedRef :: (MonadIO m) => a -> h -> m (LazilyHashedCachedRef' h store c a) makeLazilyHashedCachedRef val hsh = liftIO $ do lhCachedRef <- CachedRef <$> (newIORef $! Mem val) lhHash <- newIORef $! Some hsh @@ -206,11 +211,12 @@ makeLazilyHashedCachedRef val hsh = liftIO $ do instance ( MonadCache c m, DirectBlobStorable m a, + store ~ MBSStore m, Cache c, - CacheKey c ~ BlobRef a, + CacheKey c ~ BlobRef store a, CacheValue c ~ a ) => - BlobStorable m (LazilyHashedCachedRef' h c a) + BlobStorable m (LazilyHashedCachedRef' h store c a) where storeUpdate c = do (r, v') <- storeUpdate (lhCachedRef c) @@ -226,12 +232,13 @@ instance instance ( MonadCache c m, DirectBlobStorable m a, + store ~ MBSStore m, Cache c, - CacheKey c ~ BlobRef a, + CacheKey c ~ BlobRef store a, CacheValue c ~ a, MHashableTo m h a ) => - Cacheable m (LazilyHashedCachedRef' h c a) + Cacheable m (LazilyHashedCachedRef' h store c a) where cache r@LazilyHashedCachedRef{..} = do mhsh <- liftIO (readIORef lhHash) @@ -246,8 +253,8 @@ instance -- | A 'CachedRef' with a hash that is always computed. In particular, this means that 'load'ing -- the reference will also load the referenced data (consequently caching it) in order to -- compute the hash. -data EagerlyHashedCachedRef' h c a = EagerlyHashedCachedRef - { ehCachedRef :: !(CachedRef c a), +data EagerlyHashedCachedRef' h store c a = EagerlyHashedCachedRef + { ehCachedRef :: !(CachedRef store c a), ehHash :: !h } deriving (Show) @@ -255,21 +262,22 @@ data EagerlyHashedCachedRef' h c a = EagerlyHashedCachedRef -- | A 'CachedRef' with a hash that is eagerly computed. type EagerlyHashedCachedRef = EagerlyHashedCachedRef' H.Hash -instance HashableTo h (EagerlyHashedCachedRef' h c a) where +instance HashableTo h (EagerlyHashedCachedRef' h store c a) where getHash = ehHash {-# INLINE getHash #-} -instance (Monad m) => MHashableTo m h (EagerlyHashedCachedRef' h c a) +instance (Monad m) => MHashableTo m h (EagerlyHashedCachedRef' h store c a) instance ( MonadCache c m, DirectBlobStorable m a, + store ~ MBSStore m, Cache c, - CacheKey c ~ BlobRef a, + CacheKey c ~ BlobRef store a, CacheValue c ~ a, MHashableTo m h a ) => - Reference m (EagerlyHashedCachedRef' h c) a + Reference m store (EagerlyHashedCachedRef' h store c) a where refFlush ref = do (cr, r) <- refFlush $ ehCachedRef ref @@ -291,7 +299,7 @@ instance return EagerlyHashedCachedRef{ehCachedRef = cr, ehHash = ehHash ref} -- | Construct an 'EagerlyHashedCachedRef'' given the value and hash. -makeEagerlyHashedCachedRef :: (MonadIO m) => a -> h -> m (EagerlyHashedCachedRef' h c a) +makeEagerlyHashedCachedRef :: (MonadIO m) => a -> h -> m (EagerlyHashedCachedRef' h store c a) makeEagerlyHashedCachedRef val ehHash = do ehCachedRef <- liftIO $ CachedRef <$> (newIORef $! Mem val) return EagerlyHashedCachedRef{..} @@ -299,12 +307,13 @@ makeEagerlyHashedCachedRef val ehHash = do instance ( MonadCache c m, BlobStorable m a, + store ~ MBSStore m, Cache c, - CacheKey c ~ BlobRef a, + CacheKey c ~ BlobRef store a, CacheValue c ~ a, MHashableTo m h a ) => - BlobStorable m (EagerlyHashedCachedRef' h c a) + BlobStorable m (EagerlyHashedCachedRef' h store c a) where storeUpdate c = do (r, v') <- storeUpdate (ehCachedRef c) @@ -321,37 +330,40 @@ instance instance ( Applicative m ) => - Cacheable m (EagerlyHashedCachedRef' h c a) + Cacheable m (EagerlyHashedCachedRef' h store c a) where cache = pure -- * 'HashedCachedRef' -data MaybeHashedCachedRef h c a = HCRMem !a | HCRMemHashed !a !h | HCRDisk !(HashedCachedRef' h c a) +data MaybeHashedCachedRef h store c a + = HCRMem !a + | HCRMemHashed !a !h + | HCRDisk !(HashedCachedRef' h store c a) -- | A 'CachedRef' with a hash that is computed when first demanded (via 'getHashM'), or when the -- reference is cached (via 'refCache' or 'cache'). -data HashedCachedRef' h c a - = HCRUnflushed {hcrUnflushed :: !(IORef (MaybeHashedCachedRef h c a))} +data HashedCachedRef' h store c a + = HCRUnflushed {hcrUnflushed :: !(IORef (MaybeHashedCachedRef h store c a))} | HCRFlushed - { hcrBlob :: !(BlobRef a), + { hcrBlob :: !(BlobRef store a), hcrHash :: !h } type HashedCachedRef = HashedCachedRef' H.Hash -instance Show (HashedCachedRef' h c a) where +instance Show (HashedCachedRef' h store c a) where show _ = "" instance ( MonadCache c m, DirectBlobStorable m a, Cache c, - CacheKey c ~ BlobRef a, + CacheKey c ~ BlobRef store a, CacheValue c ~ a, MHashableTo m h a ) => - MHashableTo m h (HashedCachedRef' h c a) + MHashableTo m h (HashedCachedRef' h store c a) where getHashM HCRUnflushed{..} = liftIO (readIORef hcrUnflushed) >>= \case @@ -363,12 +375,13 @@ instance instance ( MonadCache c m, DirectBlobStorable m a, + store ~ MBSStore m, Cache c, - CacheKey c ~ BlobRef a, + CacheKey c ~ BlobRef store a, CacheValue c ~ a, MHashableTo m h a ) => - Reference m (HashedCachedRef' h c) a + Reference m store (HashedCachedRef' h store c) a where refFlush HCRUnflushed{..} = liftIO (readIORef hcrUnflushed) >>= \case @@ -423,7 +436,7 @@ instance -- | Construct a 'HashedCachedRef'' given the value and hash. -- The value is in memory, and is __not__ stored to disk. -makeHashedCachedRef :: (MonadIO m) => a -> h -> m (HashedCachedRef' h c a) +makeHashedCachedRef :: (MonadIO m) => a -> h -> m (HashedCachedRef' h store c a) makeHashedCachedRef val hsh = liftIO $ HCRUnflushed <$!> (newIORef $! HCRMemHashed val hsh) @@ -431,7 +444,10 @@ makeHashedCachedRef val hsh = -- | Construct a 'HashedCachedRef'' given the value. The value is hashed and then -- stored to disk and only a reference to blob store, and the hash of the value, -- are retained. -makeFlushedHashedCachedRef :: (MHashableTo m h a, DirectBlobStorable m a) => a -> m (HashedCachedRef' h c a) +makeFlushedHashedCachedRef :: + (MHashableTo m h a, DirectBlobStorable m a) => + a -> + m (HashedCachedRef' h (MBSStore m) c a) makeFlushedHashedCachedRef val = do h <- getHashM val (br, _) <- storeUpdateDirect val @@ -440,12 +456,13 @@ makeFlushedHashedCachedRef val = do instance ( MonadCache c m, DirectBlobStorable m a, + store ~ MBSStore m, Cache c, - CacheKey c ~ BlobRef a, + CacheKey c ~ BlobRef store a, CacheValue c ~ a, MHashableTo m h a ) => - BlobStorable m (HashedCachedRef' h c a) + BlobStorable m (HashedCachedRef' h store c a) where storeUpdate hcr = do (!hcr', !ref) <- refFlush hcr @@ -466,17 +483,18 @@ instance -- | Caching a 'HashedCachedRef' does nothing on the principle that it is generally undesirable to -- load every 'HashedCachedRef' into the cache at load time. -instance (Applicative m) => Cacheable m (HashedCachedRef c a) where +instance (Applicative m) => Cacheable m (HashedCachedRef store c a) where cache = pure instance ( MonadCache c m, DirectBlobStorable m a, + store ~ MBSStore m, Cache c, - CacheKey c ~ BlobRef a, + CacheKey c ~ BlobRef store a, CacheValue c ~ a ) => - Cacheable1 m (HashedCachedRef' h c a) a + Cacheable1 m (HashedCachedRef' h store c a) a where liftCache csh hcr@HCRUnflushed{..} = liftIO (readIORef hcrUnflushed) >>= \case @@ -512,14 +530,14 @@ migrateHashedCachedRef' :: MonadTrans t, MHashableTo m h a, CacheValue c ~ a, - CacheKey c ~ BlobRef a, + CacheKey c ~ BlobRef (MBSStore m) a, MHashableTo (t m) h b, CacheValue c' ~ b, - CacheKey c' ~ BlobRef b + CacheKey c' ~ BlobRef (MBSStore (t m)) b ) => (a -> t m b) -> - HashedCachedRef' h c a -> - t m (HashedCachedRef' h c' b) + HashedCachedRef' h (MBSStore m) c a -> + t m (HashedCachedRef' h (MBSStore (t m)) c' b) migrateHashedCachedRef' f hcr = do !v <- f =<< lift (refLoad hcr) -- compute the hash now that the value is available diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/LFMBTree.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/LFMBTree.hs index dfa627d117..dfd5b5b015 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/LFMBTree.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/LFMBTree.hs @@ -193,7 +193,7 @@ type CanStoreLFMBTree m ref v = MHashableTo m H.Hash v, -- leaf values are hashable BlobStorable m v, -- leaf values are storable BlobStorable m (ref (T ref v)), -- internal references are storable - Reference m ref (T ref v) -- internal references are references + Reference m (MBSStore m) ref (T ref v) -- internal references are references ) instance (CanStoreLFMBTree m ref v) => BlobStorable m (T ref v) where @@ -243,15 +243,15 @@ instance (CanStoreLFMBTree m ref1 v) => BlobStorable m (LFMBTree' k ref1 v) wher -- These instances are defined concretely because it is easier than -- giving complex higher-order constraints. -instance (BlobStorable m v, MHashableTo m H.Hash v, Cacheable m v) => Cacheable m (T BufferedRef v) where +instance (BlobStorable m v, store ~ MBSStore m, MHashableTo m H.Hash v, Cacheable m v) => Cacheable m (T (BufferedRef store) v) where cache (Node h l r) = Node h <$> cache l <*> cache r cache (Leaf a) = Leaf <$> cache a -instance (BlobStorable m v, MHashableTo m H.Hash v, Cacheable m v) => Cacheable m (T HashedBufferedRef v) where +instance (BlobStorable m v, store ~ MBSStore m, MHashableTo m H.Hash v, Cacheable m v) => Cacheable m (T (HashedBufferedRef store) v) where cache (Node h l r) = Node h <$> cache l <*> cache r cache (Leaf a) = Leaf <$> cache a -instance (BlobStorable m v, MHashableTo m H.Hash v, Cacheable m v) => Cacheable m (T EagerlyHashedBufferedRef v) where +instance (BlobStorable m v, store ~ MBSStore m, MHashableTo m H.Hash v, Cacheable m v) => Cacheable m (T (EagerlyHashedBufferedRef store) v) where cache (Node h l r) = Node h <$> cache l <*> cache r cache (Leaf a) = Leaf <$> cache a @@ -285,7 +285,7 @@ empty = Empty -- | Returns the value at the given key if it is present in the tree -- or Nothing otherwise. -lookup :: (CanStoreLFMBTree m ref1 (ref2 v), Ord k, Bits k, Coercible k Word64, Reference m ref2 v) => k -> LFMBTree' k ref1 (ref2 v) -> m (Maybe v) +lookup :: (CanStoreLFMBTree m ref1 (ref2 v), Ord k, Bits k, Coercible k Word64, Reference m (MBSStore m) ref2 v) => k -> LFMBTree' k ref1 (ref2 v) -> m (Maybe v) lookup a b = mapM refLoad =<< lookupRef a b -- | Return the (reference to the) value at the given key if it is present in the tree @@ -306,20 +306,20 @@ lookupRef k (NonEmpty s t) = else lookupT key =<< refLoad left -- | If a tree holds values of type @Nullable v@ then lookup should return a @Just@ if the value is present and @Nothing@ if it is not present or is a Null. This function implements such behavior. -lookupNullable :: (CanStoreLFMBTree m ref1 (ref2 (Nullable v)), Ord k, Bits k, Coercible k Word64, Reference m ref2 (Nullable v)) => k -> LFMBTree' k ref1 (ref2 (Nullable v)) -> m (Maybe v) +lookupNullable :: (CanStoreLFMBTree m ref1 (ref2 (Nullable v)), Ord k, Bits k, Coercible k Word64, Reference m (MBSStore m) ref2 (Nullable v)) => k -> LFMBTree' k ref1 (ref2 (Nullable v)) -> m (Maybe v) lookupNullable k t = lookup k t >>= \case Just (Some v) -> return $ Just v _ -> return Nothing -- | Adds reference to a value to the tree returning the assigned key and the new tree. -append :: (CanStoreLFMBTree m ref1 (ref2 v), Coercible k Word64, Num k, Reference m ref2 v) => v -> LFMBTree' k ref1 (ref2 v) -> m (k, LFMBTree' k ref1 (ref2 v)) +append :: (CanStoreLFMBTree m ref1 (ref2 v), Coercible k Word64, Num k, Reference m (MBSStore m) ref2 v) => v -> LFMBTree' k ref1 (ref2 v) -> m (k, LFMBTree' k ref1 (ref2 v)) append a b = do (x, y, _) <- appendWithRef a b return (x, y) -- | Adds a reference to a value to the tree returning the assigned key, the new tree and the created reference to the value so that it can be shared. -appendWithRef :: (CanStoreLFMBTree m ref1 (ref2 v), Coercible k Word64, Num k, Reference m ref2 v) => v -> LFMBTree' k ref1 (ref2 v) -> m (k, LFMBTree' k ref1 (ref2 v), ref2 v) +appendWithRef :: (CanStoreLFMBTree m ref1 (ref2 v), Coercible k Word64, Num k, Reference m (MBSStore m) ref2 v) => v -> LFMBTree' k ref1 (ref2 v) -> m (k, LFMBTree' k ref1 (ref2 v), ref2 v) appendWithRef v t = do ref <- refMake v (k, t') <- appendV ref t @@ -382,7 +382,7 @@ appendV value (NonEmpty s t) = do -- Otherwise, the value is loaded, modified with the given function and stored again. -- -- @update@ will also recompute the hashes on the way up to the root. -update :: (CanStoreLFMBTree m ref1 (ref2 v), Reference m ref2 v, Ord k, Bits k, Coercible k Word64) => (v -> m (a, v)) -> k -> LFMBTree' k ref1 (ref2 v) -> m (Maybe (a, LFMBTree' k ref1 (ref2 v))) +update :: (CanStoreLFMBTree m ref1 (ref2 v), Reference m (MBSStore m) ref2 v, Ord k, Bits k, Coercible k Word64) => (v -> m (a, v)) -> k -> LFMBTree' k ref1 (ref2 v) -> m (Maybe (a, LFMBTree' k ref1 (ref2 v))) update _ _ Empty = return Nothing update f k (NonEmpty s t) = if k >= coerce s @@ -412,7 +412,7 @@ update f k (NonEmpty s t) = -- | If a tree holds values of type @Maybe v@ then deleting is done by inserting a @Nothing@ at a given position. -- This function will return Nothing if the key is not present and otherwise it will return the updated tree. -delete :: (CanStoreLFMBTree m ref1 (ref2 (Nullable v)), Ord k, Bits k, Coercible k Word64, Reference m ref2 (Nullable v)) => k -> LFMBTree' k ref1 (ref2 (Nullable v)) -> m (Maybe (LFMBTree' k ref1 (ref2 (Nullable v)))) +delete :: (CanStoreLFMBTree m ref1 (ref2 (Nullable v)), Ord k, Bits k, Coercible k Word64, Reference m (MBSStore m) ref2 (Nullable v)) => k -> LFMBTree' k ref1 (ref2 (Nullable v)) -> m (Maybe (LFMBTree' k ref1 (ref2 (Nullable v)))) delete k t = do v <- update (const $ return ((), Null)) k t return $ fmap snd v @@ -420,7 +420,7 @@ delete k t = do -- | Return the elements sorted by their keys. As there is no operation -- for deleting elements, this list will contain all the elements starting -- on the index 0 up to the size of the tree. -toAscList :: (CanStoreLFMBTree m ref1 (ref2 v), Reference m ref2 v) => LFMBTree' k ref1 (ref2 v) -> m [v] +toAscList :: (CanStoreLFMBTree m ref1 (ref2 v), Reference m (MBSStore m) ref2 v) => LFMBTree' k ref1 (ref2 v) -> m [v] toAscList Empty = return [] toAscList (NonEmpty _ t) = toListT t where @@ -432,12 +432,12 @@ toAscList (NonEmpty _ t) = toListT t -- | Return the pairs (key, value) sorted by their keys. This list will contain -- all the elements starting on the index 0. -toAscPairList :: (CanStoreLFMBTree m ref1 (ref2 v), Coercible k Word64, Reference m ref2 v) => LFMBTree' k ref1 (ref2 v) -> m [(k, v)] +toAscPairList :: (CanStoreLFMBTree m ref1 (ref2 v), Coercible k Word64, Reference m (MBSStore m) ref2 v) => LFMBTree' k ref1 (ref2 v) -> m [(k, v)] toAscPairList t = zip (map coerce [0 :: Word64 ..]) <$> toAscList t -- | Create a tree from a list of items. The items will be inserted sequentially -- starting on the index 0. -fromAscList :: (CanStoreLFMBTree m ref1 (ref2 v), Num k, Coercible k Word64, Reference m ref2 v) => [v] -> m (LFMBTree' k ref1 (ref2 v)) +fromAscList :: (CanStoreLFMBTree m ref1 (ref2 v), Num k, Coercible k Word64, Reference m (MBSStore m) ref2 v) => [v] -> m (LFMBTree' k ref1 (ref2 v)) fromAscList = foldM (\acc e -> snd <$> append e acc) empty -- | Create a tree from a list of items. The items will be inserted sequentially @@ -446,7 +446,7 @@ fromAscListV :: forall k m ref v. (CanStoreLFMBTree m ref v, Num k, Coercible k fromAscListV = foldM (\acc e -> snd <$> appendV e acc) empty -- | Create a tree that holds the values wrapped in @Some@ when present and keeps @Null@s on the missing positions -fromAscListNullable :: (CanStoreLFMBTree m ref1 (ref2 (Nullable v)), Coercible k Word64, Integral k, Reference m ref2 (Nullable v)) => [(k, v)] -> m (LFMBTree' k ref1 (ref2 (Nullable v))) +fromAscListNullable :: (CanStoreLFMBTree m ref1 (ref2 (Nullable v)), Coercible k Word64, Integral k, Reference m (MBSStore m) ref2 (Nullable v)) => [(k, v)] -> m (LFMBTree' k ref1 (ref2 (Nullable v))) fromAscListNullable l = fromAscList $ go l 0 where go z@((i, v) : xs) ix @@ -456,7 +456,7 @@ fromAscListNullable l = fromAscList $ go l 0 -- | Fold a monadic action over the tree in ascending order of index. -- This is strict in the intermediate results. -mfold :: (CanStoreLFMBTree m ref1 (ref2 v), Reference m ref2 v) => (a -> v -> m a) -> a -> LFMBTree' k ref1 (ref2 v) -> m a +mfold :: (CanStoreLFMBTree m ref1 (ref2 v), Reference m (MBSStore m) ref2 v) => (a -> v -> m a) -> a -> LFMBTree' k ref1 (ref2 v) -> m a mfold _ a0 Empty = return a0 mfold f !a0 (NonEmpty _ t) = mfoldT a0 t where @@ -467,7 +467,7 @@ mfold f !a0 (NonEmpty _ t) = mfoldT a0 t -- | Fold a monadic action over the tree in descending order of index. -- This is strict in the intermediate results. -mfoldDesc :: (CanStoreLFMBTree m ref1 (ref2 v), Reference m ref2 v) => (a -> v -> m a) -> a -> LFMBTree' k ref1 (ref2 v) -> m a +mfoldDesc :: (CanStoreLFMBTree m ref1 (ref2 v), Reference m (MBSStore m) ref2 v) => (a -> v -> m a) -> a -> LFMBTree' k ref1 (ref2 v) -> m a mfoldDesc _ a0 Empty = return a0 mfoldDesc f !a0 (NonEmpty _ t) = mfoldT a0 t where @@ -477,7 +477,7 @@ mfoldDesc f !a0 (NonEmpty _ t) = mfoldT a0 t mfoldT a' =<< refLoad l -- | Map a monadic action over the tree in ascending order of index, discarding the results. -mmap_ :: (CanStoreLFMBTree m ref1 (ref2 v), Reference m ref2 v) => (v -> m ()) -> LFMBTree' k ref1 (ref2 v) -> m () +mmap_ :: (CanStoreLFMBTree m ref1 (ref2 v), Reference m (MBSStore m) ref2 v) => (v -> m ()) -> LFMBTree' k ref1 (ref2 v) -> m () mmap_ _ Empty = return () mmap_ f (NonEmpty _ t) = mmap_T t where @@ -491,7 +491,7 @@ mmap_ f (NonEmpty _ t) = mmap_T t -- index. migrateLFMBTree :: forall m t ref1 ref2 v1 v2 k. - (CanStoreLFMBTree m ref1 v1, Reference (t m) ref2 (T ref2 v2), MonadTrans t) => + (CanStoreLFMBTree m ref1 v1, Reference (t m) (MBSStore (t m)) ref2 (T ref2 v2), MonadTrans t) => (v1 -> t m v2) -> LFMBTree' k ref1 v1 -> t m (LFMBTree' k ref2 v2) diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/LMDB.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/LMDB.hs index 15dfe2221b..112012cb32 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/LMDB.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/LMDB.hs @@ -124,7 +124,7 @@ class (S.Serialize a) => FixedSizeSerialization a where instance FixedSizeSerialization () where serializedSize _ = 0 -instance FixedSizeSerialization (BlobRef a) where +instance FixedSizeSerialization (BlobRef store a) where serializedSize _ = 8 -- This instance is needed for paired state. diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/PoolRewards.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/PoolRewards.hs index 53520bcab7..7650daed97 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/PoolRewards.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/PoolRewards.hs @@ -38,22 +38,22 @@ import qualified Concordium.GlobalState.Persistent.LFMBTree as LFMBT import Concordium.GlobalState.PoolRewards import Concordium.GlobalState.Rewards -type CapitalDistributionRef (bhv :: BlockHashVersion) = - HashedBufferedRef' (CapitalDistributionHash' bhv) CapitalDistribution +type CapitalDistributionRef store (bhv :: BlockHashVersion) = + HashedBufferedRef' (CapitalDistributionHash' bhv) store CapitalDistribution -- | Details of rewards accruing over the course of a reward period, and details about the capital -- distribution for this reward period and (possibly) the next. Note, 'currentCapital' and -- 'nextCapital' are the same except in the epoch before a payday, where 'nextCapital' is updated -- to record the capital distribution for the next reward period. -data PoolRewards (bhv :: BlockHashVersion) = PoolRewards +data PoolRewards store (bhv :: BlockHashVersion) = PoolRewards { -- | The capital distribution for the next reward period. -- This is updated the epoch before a payday. - nextCapital :: !(CapitalDistributionRef bhv), + nextCapital :: !(CapitalDistributionRef store bhv), -- | The capital distribution for the current reward period. - currentCapital :: !(CapitalDistributionRef bhv), + currentCapital :: !(CapitalDistributionRef store bhv), -- | The details of rewards accruing to baker pools. -- These are indexed by the index of the baker in the capital distribution (_not_ the BakerId). - bakerPoolRewardDetails :: !(LFMBT.LFMBTree Word64 BufferedRef BakerPoolRewardDetails), + bakerPoolRewardDetails :: !(LFMBT.LFMBTree Word64 (BufferedRef store) BakerPoolRewardDetails), -- | The transaction reward amount accruing to the passive delegators. passiveDelegationTransactionRewards :: !Amount, -- | The transaction reward fraction accruing to the foundation. @@ -71,8 +71,8 @@ data PoolRewards (bhv :: BlockHashVersion) = PoolRewards migratePoolRewards :: (SupportMigration m t, IsBlockHashVersion bhv1) => Epoch -> - PoolRewards bhv0 -> - t m (PoolRewards bhv1) + PoolRewards (MBSStore m) bhv0 -> + t m (PoolRewards (MBSStore (t m)) bhv1) migratePoolRewards newNextPayday PoolRewards{..} = do nextCapital' <- migrateHashedBufferedRef return nextCapital currentCapital' <- migrateHashedBufferedRef return currentCapital @@ -102,7 +102,7 @@ migratePoolRewardsP1 :: Epoch -> -- | Mint rate for the next payday MintRate -> - m (PoolRewards bhv) + m (PoolRewards (MBSStore m) bhv) migratePoolRewardsP1 curBakers nextBakers blockCounts npEpoch npMintRate = do (nextCapital, _) <- refFlush =<< bufferHashed (makeCD nextBakers) (currentCapital, _) <- refFlush =<< bufferHashed (makeCD curBakers) @@ -121,7 +121,7 @@ migratePoolRewardsP1 curBakers nextBakers blockCounts npEpoch npMintRate = do passiveDelegatorsCapital = Vec.empty } makeBakerCapital (bid, amt) = BakerCapital bid amt Vec.empty - makePRD :: (BakerId, a) -> m (BufferedRef BakerPoolRewardDetails) + makePRD :: (BakerId, a) -> m (BufferedRef (MBSStore m) BakerPoolRewardDetails) makePRD (bid, _) = do let bprd = BakerPoolRewardDetails @@ -136,7 +136,7 @@ migratePoolRewardsP1 curBakers nextBakers blockCounts npEpoch npMintRate = do lookupBakerCapitalAndRewardDetails :: (MonadBlobStore m, IsBlockHashVersion bhv) => BakerId -> - PoolRewards bhv -> + PoolRewards (MBSStore m) bhv -> m (Maybe (BakerCapital, BakerPoolRewardDetails)) lookupBakerCapitalAndRewardDetails bid PoolRewards{..} = do cdistr <- refLoad currentCapital @@ -145,7 +145,7 @@ lookupBakerCapitalAndRewardDetails bid PoolRewards{..} = do Just (index, capital) -> fmap (capital,) <$> LFMBT.lookup (fromIntegral index) bakerPoolRewardDetails -instance (MonadBlobStore m) => BlobStorable m (PoolRewards bhv) where +instance (MonadBlobStore m, store ~ MBSStore m) => BlobStorable m (PoolRewards store bhv) where storeUpdate pr0 = do (pNextCapital, nextCapital) <- storeUpdate (nextCapital pr0) (pCurrentCapital, currentCapital) <- storeUpdate (currentCapital pr0) @@ -187,7 +187,7 @@ instance (MonadBlobStore m) => BlobStorable m (PoolRewards bhv) where -- | Serialize 'PoolRewards'. -- The 'bakerPoolRewardDetails' is serialized as a flat list, with the length implied by the -- length of 'bakerPoolCapital' of 'currentCapital'. -putPoolRewards :: (MonadBlobStore m, MonadPut m, IsBlockHashVersion bhv) => PoolRewards bhv -> m () +putPoolRewards :: (MonadBlobStore m, MonadPut m, IsBlockHashVersion bhv) => PoolRewards (MBSStore m) bhv -> m () putPoolRewards PoolRewards{..} = do nxtCapital <- refLoad nextCapital curCapital <- refLoad currentCapital @@ -202,7 +202,7 @@ putPoolRewards PoolRewards{..} = do put nextPaydayEpoch put nextPaydayMintRate -instance (MonadBlobStore m, IsBlockHashVersion bhv) => MHashableTo m (PoolRewardsHash bhv) (PoolRewards bhv) where +instance (MonadBlobStore m, store ~ MBSStore m, IsBlockHashVersion bhv) => MHashableTo m (PoolRewardsHash bhv) (PoolRewards store bhv) where getHashM PoolRewards{..} = do hNextCapital <- getHashM nextCapital hCurrentCapital <- getHashM currentCapital @@ -218,7 +218,7 @@ instance (MonadBlobStore m, IsBlockHashVersion bhv) => MHashableTo m (PoolReward <> put nextPaydayEpoch <> put nextPaydayMintRate -instance (MonadBlobStore m, IsBlockHashVersion bhv) => Cacheable m (PoolRewards bhv) where +instance (MonadBlobStore m, store ~ MBSStore m, IsBlockHashVersion bhv) => Cacheable m (PoolRewards store bhv) where cache pr@PoolRewards{nextPaydayEpoch = nextPaydayEpoch, nextPaydayMintRate = nextPaydayMintRate} = do nextCapital <- cache (nextCapital pr) currentCapital <- cache (currentCapital pr) @@ -228,7 +228,7 @@ instance (MonadBlobStore m, IsBlockHashVersion bhv) => Cacheable m (PoolRewards return PoolRewards{..} -- | The empty 'PoolRewards'. -emptyPoolRewards :: (MonadBlobStore m, IsBlockHashVersion bhv) => m (PoolRewards bhv) +emptyPoolRewards :: (MonadBlobStore m, store ~ MBSStore m, IsBlockHashVersion bhv) => m (PoolRewards store bhv) emptyPoolRewards = do emptyCDRef <- refMake emptyCapitalDistribution return @@ -243,7 +243,7 @@ emptyPoolRewards = do } -- | List of baker and number of blocks baked by this baker in the reward period. -bakerBlockCounts :: (MonadBlobStore m, IsBlockHashVersion bhv) => PoolRewards bhv -> m [(BakerId, Word64)] +bakerBlockCounts :: (MonadBlobStore m, IsBlockHashVersion bhv) => PoolRewards (MBSStore m) bhv -> m [(BakerId, Word64)] bakerBlockCounts PoolRewards{..} = do cc <- refLoad currentCapital rds <- LFMBT.toAscPairList bakerPoolRewardDetails @@ -258,9 +258,12 @@ bakerBlockCounts PoolRewards{..} = do -- | Rotate the capital distribution, so that the current capital distribution is replaced by the -- next one, and set up empty pool rewards. rotateCapitalDistribution :: - (MonadBlobStore m, Reference m ref (PoolRewards bhv), IsBlockHashVersion bhv) => - ref (PoolRewards bhv) -> - m (ref (PoolRewards bhv)) + ( MonadBlobStore m, + Reference m (MBSStore m) ref (PoolRewards (MBSStore m) bhv), + IsBlockHashVersion bhv + ) => + ref (PoolRewards (MBSStore m) bhv) -> + m (ref (PoolRewards (MBSStore m) bhv)) rotateCapitalDistribution oldPoolRewards = do pr <- refLoad oldPoolRewards nextCap <- refLoad (nextCapital pr) @@ -276,11 +279,14 @@ rotateCapitalDistribution oldPoolRewards = do } setNextCapitalDistribution :: - (MonadBlobStore m, Reference m ref (PoolRewards bhv), IsBlockHashVersion bhv) => + ( MonadBlobStore m, + Reference m (MBSStore m) ref (PoolRewards (MBSStore m) bhv), + IsBlockHashVersion bhv + ) => [(BakerId, Amount, [(DelegatorId, Amount)])] -> [(DelegatorId, Amount)] -> - ref (PoolRewards bhv) -> - m (ref (PoolRewards bhv)) + ref (PoolRewards (MBSStore m) bhv) -> + m (ref (PoolRewards (MBSStore m) bhv)) setNextCapitalDistribution bakers passive oldPoolRewards = do let bakerPoolCapital = Vec.fromList $ map mkBakCap bakers let passiveDelegatorsCapital = Vec.fromList $ map mkDelCap passive @@ -297,7 +303,7 @@ setNextCapitalDistribution bakers passive oldPoolRewards = do -- | The total capital passively delegated in the current reward period capital distribution. currentPassiveDelegationCapital :: (MonadBlobStore m, IsBlockHashVersion bhv) => - PoolRewards bhv -> + PoolRewards (MBSStore m) bhv -> m Amount currentPassiveDelegationCapital PoolRewards{..} = Vec.sum . fmap dcDelegatorCapital . passiveDelegatorsCapital <$> refLoad currentCapital diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Trie.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Trie.hs index f60d02ca6b..14916d5028 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Trie.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Trie.hs @@ -45,6 +45,7 @@ import Concordium.GlobalState.Persistent.BlobStore ( BufferedFix (..), Cacheable (..), FixShowable (..), + MBSStore, Nullable (..), Reference (..), UnbufferedFix (..), @@ -496,8 +497,8 @@ migrateTrieN :: -- | Flag that indicates whether the new trie should be cached in memory or not. Bool -> (v1 -> t m v2) -> - TrieN BufferedFix k v1 -> - t m (TrieN BufferedFix k v2) + TrieN (BufferedFix (MBSStore m)) k v1 -> + t m (TrieN (BufferedFix (MBSStore (t m))) k v2) migrateTrieN _ _ EmptyTrieN = return EmptyTrieN migrateTrieN cacheNew f (TrieN n root) = do trieF <- lift (refLoad (unBF root)) @@ -512,8 +513,8 @@ migrateTrieF :: -- | Flag that indicates whether the new trie should be cached in memory or not. Bool -> (v1 -> t m v2) -> - TrieF k v1 (BufferedFix (TrieF k v1)) -> - t m (TrieF k v2 (BufferedFix (TrieF k v2))) + TrieF k v1 (BufferedFix (MBSStore m) (TrieF k v1)) -> + t m (TrieF k v2 (BufferedFix (MBSStore (t m)) (TrieF k v2))) migrateTrieF _ f (Tip v) = Tip <$!> f v migrateTrieF cacheNew f (Stem stem r) = do !child <- lift (refLoad (unBF r)) @@ -535,8 +536,8 @@ migrateUnbufferedTrieN :: forall v1 v2 k m t. (BlobStorable m v1, BlobStorable (t m) v2, MonadTrans t) => (v1 -> t m v2) -> - TrieN UnbufferedFix k v1 -> - t m (TrieN UnbufferedFix k v2) + TrieN (UnbufferedFix (MBSStore m)) k v1 -> + t m (TrieN (UnbufferedFix (MBSStore (t m))) k v2) migrateUnbufferedTrieN _ EmptyTrieN = return EmptyTrieN migrateUnbufferedTrieN f (TrieN n root) = do trieF <- lift (refLoad (unUF root)) @@ -547,8 +548,8 @@ migrateUnbufferedTrieN f (TrieN n root) = do migrateUnbufferedTrieF :: (BlobStorable m v1, BlobStorable (t m) v2, MonadTrans t) => (v1 -> t m v2) -> - TrieF k v1 (UnbufferedFix (TrieF k v1)) -> - t m (TrieF k v2 (UnbufferedFix (TrieF k v2))) + TrieF k v1 (UnbufferedFix (MBSStore m) (TrieF k v1)) -> + t m (TrieF k v2 (UnbufferedFix (MBSStore (t m)) (TrieF k v2))) migrateUnbufferedTrieF f (Tip v) = Tip <$!> f v migrateUnbufferedTrieF f (Stem stem r) = do !child <- lift (refLoad (unUF r)) From a81e98a51fd6c9efd02c5128d4dceaf4bb50291a Mon Sep 17 00:00:00 2001 From: Thomas Dinsdale-Young Date: Thu, 28 May 2026 13:49:15 +0200 Subject: [PATCH 2/2] WIP --- .../src/Concordium/Birk/Bake.hs | 9 +- .../src/Concordium/GlobalState.hs | 42 +- .../src/Concordium/GlobalState/BlockState.hs | 2 - .../Concordium/GlobalState/ContractStateV1.hs | 32 +- .../GlobalState/Persistent/Account.hs | 20 +- .../Persistent/Account/MigrationState.hs | 62 +- .../Persistent/Account/ProtocolLevelTokens.hs | 26 +- .../Persistent/Account/StructureV1.hs | 98 +- .../GlobalState/Persistent/Accounts.hs | 7 +- .../GlobalState/Persistent/Bakers.hs | 142 ++- .../GlobalState/Persistent/BlobStore.hs | 10 +- .../GlobalState/Persistent/BlockState.hs | 1055 +++++++++-------- .../Persistent/BlockState/Modules.hs | 166 ++- .../BlockState/ProtocolLevelTokens.hs | 108 +- .../Persistent/BlockState/Updates.hs | 37 +- .../GlobalState/Persistent/CachedRef.hs | 6 +- .../GlobalState/Persistent/Cooldown.hs | 72 +- .../GlobalState/Persistent/Genesis.hs | 32 +- .../GlobalState/Persistent/Instances.hs | 215 ++-- .../GlobalState/Persistent/PoolRewards.hs | 6 +- .../GlobalState/Persistent/ReleaseSchedule.hs | 76 +- .../GlobalState/Persistent/TreeState.hs | 84 +- .../src/Concordium/ImportExport.hs | 6 +- .../src/Concordium/KonsensusV1.hs | 21 +- .../src/Concordium/KonsensusV1/Consensus.hs | 47 +- .../KonsensusV1/Consensus/Blocks.hs | 77 +- .../KonsensusV1/Consensus/CatchUp.hs | 17 +- .../KonsensusV1/Consensus/Finality.hs | 43 +- .../KonsensusV1/Consensus/Quorum.hs | 27 +- .../KonsensusV1/Consensus/Timeout.hs | 27 +- .../KonsensusV1/Consensus/Timeout/Internal.hs | 13 +- .../src/Concordium/KonsensusV1/Scheduler.hs | 26 +- .../src/Concordium/KonsensusV1/SkovMonad.hs | 326 ++--- .../src/Concordium/KonsensusV1/TestMonad.hs | 104 +- .../Concordium/KonsensusV1/Transactions.hs | 35 +- .../KonsensusV1/TreeState/Implementation.hs | 192 +-- .../KonsensusV1/TreeState/LowLevel.hs | 38 +- .../KonsensusV1/TreeState/LowLevel/LMDB.hs | 90 +- .../KonsensusV1/TreeState/LowLevel/Memory.hs | 43 +- .../KonsensusV1/TreeState/StartUp.hs | 25 +- .../Concordium/KonsensusV1/TreeState/Types.hs | 62 +- .../src/Concordium/MultiVersion.hs | 207 ++-- .../src/Concordium/ProtocolUpdate/P10.hs | 7 +- .../Concordium/ProtocolUpdate/P10/Reboot.hs | 7 +- .../src/Concordium/ProtocolUpdate/P6.hs | 7 +- .../ProtocolUpdate/P6/ProtocolP7.hs | 7 +- .../Concordium/ProtocolUpdate/P6/Reboot.hs | 7 +- .../src/Concordium/ProtocolUpdate/P7.hs | 7 +- .../ProtocolUpdate/P7/ProtocolP8.hs | 7 +- .../Concordium/ProtocolUpdate/P7/Reboot.hs | 7 +- .../src/Concordium/ProtocolUpdate/P8.hs | 7 +- .../ProtocolUpdate/P8/ProtocolP9.hs | 7 +- .../Concordium/ProtocolUpdate/P8/Reboot.hs | 7 +- .../src/Concordium/ProtocolUpdate/P9.hs | 7 +- .../ProtocolUpdate/P9/ProtocolP10.hs | 7 +- .../Concordium/ProtocolUpdate/P9/Reboot.hs | 7 +- .../src/Concordium/ProtocolUpdate/V1.hs | 7 +- .../src/Concordium/Queries.hs | 149 +-- .../src/Concordium/Scheduler.hs | 3 +- .../src/Concordium/Scheduler/DummyData.hs | 4 +- .../src/Concordium/Scheduler/Environment.hs | 64 +- .../Scheduler/EnvironmentImplementation.hs | 3 + .../Concordium/Scheduler/InvokeContract.hs | 3 + .../Scheduler/WasmIntegration/V1.hs | 54 +- .../src/Concordium/Skov/Monad.hs | 4 + .../Concordium/Skov/MonadImplementations.hs | 342 +++--- .../test-runners/deterministic/Main.hs | 7 +- 67 files changed, 2479 insertions(+), 1992 deletions(-) diff --git a/concordium-consensus/src/Concordium/Birk/Bake.hs b/concordium-consensus/src/Concordium/Birk/Bake.hs index 0a88d6c7ab..69a7fabe02 100644 --- a/concordium-consensus/src/Concordium/Birk/Bake.hs +++ b/concordium-consensus/src/Concordium/Birk/Bake.hs @@ -200,8 +200,13 @@ class (SkovMonad m, FinalizationMonad m) => BakerMonad m where tryBake :: BakerIdentity -> Slot -> m BakeResult instance - (FinalizationMonad (SkovT pv h c m), MonadIO m, SkovMonad (SkovT pv h c m), TreeStateMonad (SkovT pv h c m), OnSkov (SkovT pv h c m)) => - BakerMonad (SkovT pv h c m) + ( FinalizationMonad (SkovT store pv h c m), + MonadIO m, + SkovMonad (SkovT store pv h c m), + TreeStateMonad (SkovT store pv h c m), + OnSkov (SkovT store pv h c m) + ) => + BakerMonad (SkovT store pv h c m) where bakeForSlot = doBakeForSlot tryBake = doTryBake diff --git a/concordium-consensus/src/Concordium/GlobalState.hs b/concordium-consensus/src/Concordium/GlobalState.hs index 5a17d71bee..067b55b498 100644 --- a/concordium-consensus/src/Concordium/GlobalState.hs +++ b/concordium-consensus/src/Concordium/GlobalState.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingVia #-} +{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} @@ -52,10 +53,12 @@ instance Show GlobalStateInitException where instance Exception GlobalStateInitException -- | The read-only context type associated with a global state configuration. -type GSContext pv = PersistentBlockStateContext pv +type GSContext store pv = PersistentBlockStateContext store pv -- | The (mutable) state type associated with a global state configuration. -type GSState pv = SkovPersistentData pv +type GSState store pv = SkovPersistentData store pv + +data InitialisedState pv = forall store. InitialisedState (GSContext store pv) (GSState store pv) -- | Generate context and state from the initial configuration if the state -- exists already. This may have 'IO' side effects to set up any necessary @@ -68,7 +71,10 @@ type GSState pv = SkovPersistentData pv -- Note that even if the state is successfully loaded it is not in a usable -- state for an active consensus and must be activated before. Use -- 'activateGlobalState' for that. -initialiseExistingGlobalState :: forall pv. (IsProtocolVersion pv) => SProtocolVersion pv -> GlobalStateConfig -> LogIO (Maybe (GSContext pv, GSState pv)) +initialiseExistingGlobalState :: + forall pv. + (IsProtocolVersion pv) => + SProtocolVersion pv -> GlobalStateConfig -> LogIO (Maybe (InitialisedState pv)) initialiseExistingGlobalState _ GlobalStateConfig{..} = do -- check if all the necessary database files exist existingDB <- checkExistingDatabase dtdbTreeStateDirectory dtdbBlockStateFile @@ -84,13 +90,14 @@ initialiseExistingGlobalState _ GlobalStateConfig{..} = do skovData <- runLoggerT (loadSkovPersistentData dtdbRuntimeParameters dtdbTreeStateDirectory pbsc) logm `onException` closeBlobStore pbscBlobStore - return (Just (pbsc, skovData)) + return (Just $ InitialisedState 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 -> IO (PersistentBlockStateContext store pv) initializePersistentBlockStateContext GlobalStateConfig{..} = do pbscBlobStore <- createBlobStore dtdbBlockStateFile pbscAccountCache <- newAccountCache (rpAccountsCacheSize dtdbRuntimeParameters) @@ -118,15 +125,15 @@ migrateExistingState :: -- | The configuration. GlobalStateConfig -> -- | Global state context for the state we are migrating from. - GSContext oldpv -> + GSContext oldstore oldpv -> -- | The state of the chain we are migrating from. See documentation above for assumptions. - GSState oldpv -> + GSState oldstore oldpv -> -- | Auxiliary migration data. StateMigrationParameters oldpv pv -> -- | Regenesis data for the new chain. This is in effect the genesis block of the new chain. Regenesis pv -> -- | The return value is the context and state for the new chain. - LogIO (GSContext pv, GSState pv) + LogIO (InitialisedState pv) migrateExistingState gsc@GlobalStateConfig{..} oldPbsc oldState migration genData = do pbsc <- liftIO $ initializePersistentBlockStateContext gsc newInitialBlockState <- flip runBlobStoreT oldPbsc . flip runBlobStoreT pbsc $ do @@ -148,12 +155,14 @@ migrateExistingState gsc@GlobalStateConfig{..} oldPbsc oldState migration genDat isd <- runReaderT (runPersistentBlockStateMonad initGS) pbsc `onException` liftIO (destroyBlobStore (pbscBlobStore pbsc)) - return (pbsc, isd) + return (InitialisedState 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 :: + (IsProtocolVersion pv, IsConsensusV0 pv) => + GenesisData pv -> GlobalStateConfig -> LogIO (InitialisedState pv) initialiseNewGlobalState genData gsc@GlobalStateConfig{..} = do pbsc@PersistentBlockStateContext{..} <- liftIO $ initializePersistentBlockStateContext gsc let initGS = do @@ -169,10 +178,13 @@ initialiseNewGlobalState genData gsc@GlobalStateConfig{..} = do isd <- runReaderT (runPersistentBlockStateMonad initGS) pbsc `onException` liftIO (destroyBlobStore pbscBlobStore) - return (pbsc, isd) + return (InitialisedState pbsc isd) -- | Either initialise an existing state, or if it does not exist, initialise a new one with the given genesis. -initialiseGlobalState :: forall pv. (IsProtocolVersion pv, IsConsensusV0 pv) => GenesisData pv -> GlobalStateConfig -> LogIO (GSContext pv, GSState pv) +initialiseGlobalState :: + forall pv. + (IsProtocolVersion pv, IsConsensusV0 pv) => + GenesisData pv -> GlobalStateConfig -> LogIO (InitialisedState pv) initialiseGlobalState gd cfg = initialiseExistingGlobalState (protocolVersion @pv) cfg >>= \case Nothing -> initialiseNewGlobalState gd cfg @@ -180,11 +192,13 @@ initialiseGlobalState gd cfg = -- | Establish all the necessary invariants so that the state can be used by -- consensus. This should only be called once per initialised state. -activateGlobalState :: (IsProtocolVersion pv) => Proxy pv -> GSContext pv -> GSState pv -> LogIO (GSState pv) +activateGlobalState :: + (IsProtocolVersion pv) => + Proxy pv -> GSContext store pv -> GSState store pv -> LogIO (GSState store pv) activateGlobalState _ = activateSkovPersistentData -- | Shutdown the global state. -shutdownGlobalState :: SProtocolVersion pv -> GSContext pv -> GSState pv -> IO () +shutdownGlobalState :: SProtocolVersion pv -> GSContext store pv -> GSState store pv -> IO () shutdownGlobalState _ PersistentBlockStateContext{..} st = do closeBlobStore pbscBlobStore closeSkovPersistentData st diff --git a/concordium-consensus/src/Concordium/GlobalState/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/BlockState.hs index cd0648c20c..cdf5c5531e 100644 --- a/concordium-consensus/src/Concordium/GlobalState/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/BlockState.hs @@ -1981,7 +1981,6 @@ instance (Monad (t m), MonadTrans t, AccountOperations m) => AccountOperations ( {-# INLINE getAccountTokens #-} {-# INLINE getAccountTokenBalance #-} -type instance MBSStore (MGSTrans t m) = MBSStore m instance (Monad (t m), MonadTrans t, ContractStateOperations m) => ContractStateOperations (MGSTrans t m) where thawContractState = lift . thawContractState {-# INLINE thawContractState #-} @@ -2178,7 +2177,6 @@ instance (Monad (t m), MonadTrans t, BlockStateStorage m) => BlockStateStorage ( {-# INLINE cacheBlockStateAndGetTransactionTable #-} {-# INLINE tryPopulateGlobalMaps #-} -type instance MBSStore (MaybeT m) = MBSStore m deriving via (MGSTrans MaybeT m) instance (TokenStateOperations ts m) => TokenStateOperations ts (MaybeT m) deriving via (MGSTrans MaybeT m) instance (PLTQuery bs ts m) => PLTQuery bs ts (MaybeT m) deriving via (MGSTrans MaybeT m) instance (BlockStateQuery m) => BlockStateQuery (MaybeT m) diff --git a/concordium-consensus/src/Concordium/GlobalState/ContractStateV1.hs b/concordium-consensus/src/Concordium/GlobalState/ContractStateV1.hs index fcf243bf22..e5152ce361 100644 --- a/concordium-consensus/src/Concordium/GlobalState/ContractStateV1.hs +++ b/concordium-consensus/src/Concordium/GlobalState/ContractStateV1.hs @@ -8,6 +8,7 @@ module Concordium.GlobalState.ContractStateV1 ( PersistentState, InMemoryPersistentState (..), MutableState (..), + ForeignMutableState, MutableStateInner, emptyPersistentState, newMutableState, @@ -81,20 +82,20 @@ withMutableState MutableState{msInner = MutableStateInner fp} = withForeignPtr f foreign import ccall "lookup_entry_value_mutable_state" lookupEntryValueMutableStateFFI :: -- | Callback for loading persistent nodes into memory. - LoadCallback -> + LoadCallback store -> -- | Location of the key. Ptr Word8 -> -- | Length of the key. CSize -> -- | Reference to the mutable state. - Ptr MutableStateInner -> + Ptr (ForeignMutableState store) -> -- | Location for returning the length of the output. Ptr CSize -> -- | Returns pointer to the value, null pointer if no entry was found. IO (Ptr Word8) -- | Look up entry using key and read the value in a mutable state. -lookupMutableState :: BS.ByteString -> MutableState -> IO (Maybe BS.ByteString) +lookupMutableState :: BS.ByteString -> MutableState store -> IO (Maybe BS.ByteString) lookupMutableState key state = BSU.unsafeUseAsCStringLen key $ \(keyPtr, keyLen) -> alloca $ \outPtr -> do response <- withMutableState state $ \inner -> @@ -123,7 +124,7 @@ lookupMutableState key state = BSU.unsafeUseAsCStringLen key $ \(keyPtr, keyLen) foreign import ccall "insert_entry_value_mutable_state" insertEntryValueMutableStateFFI :: -- | Callback for loading persistent nodes into memory. - LoadCallback -> + LoadCallback store -> -- | Location of the key. Ptr Word8 -> -- | Length of the key. @@ -133,7 +134,7 @@ foreign import ccall "insert_entry_value_mutable_state" -- | Length of the value. CSize -> -- | Reference to the mutable state. - Ptr MutableStateInner -> + Ptr (ForeignMutableState store) -> IO Word8 -- | Insert a value into the mutable state at a specified key. @@ -148,7 +149,7 @@ insertMutableState :: -- | Value to insert into the mutable state. BS.ByteString -> -- | The mutable state to modify. - MutableState -> + MutableState store -> IO (Maybe Bool) insertMutableState key value state = BSU.unsafeUseAsCStringLen key $ \(keyPtr, keyLen) -> BSU.unsafeUseAsCStringLen value $ \(valuePtr, valueLen) -> @@ -176,13 +177,13 @@ insertMutableState key value state = BSU.unsafeUseAsCStringLen key $ \(keyPtr, k foreign import ccall "delete_entry_mutable_state" deleteEntryMutableStateFFI :: -- | Callback for loading persistent nodes into memory. - LoadCallback -> + LoadCallback store -> -- | Location of the key. Ptr Word8 -> -- | Length of the key. CSize -> -- | Reference to the mutable state. - Ptr MutableStateInner -> + Ptr (ForeignMutableState store) -> IO Word8 -- | Delete entry at key. @@ -195,7 +196,7 @@ deleteEntryMutableState :: -- | Key of the entry in the mutable state to delete. BS.ByteString -> -- | The mutable state to delete from. - MutableState -> + MutableState store -> IO (Maybe Bool) deleteEntryMutableState key mutableState = BSU.unsafeUseAsCStringLen key $ \(keyPtr, keyLen) -> @@ -229,10 +230,10 @@ newtype PersistentState store = PersistentState (ForeignPtr (ForeignPersistentSt newtype InMemoryPersistentState store = InMemoryPersistentState (PersistentState store) -- | Allocate empty persistent state. -foreign import ccall "empty_persistent_state" empty_persistent_state :: IO (Ptr PersistentState) +foreign import ccall "empty_persistent_state" empty_persistent_state :: IO (Ptr (ForeignPersistentState store)) -- | Allocate empty persistent state. -emptyPersistentState :: IO PersistentState +emptyPersistentState :: IO (PersistentState store) emptyPersistentState = do state <- empty_persistent_state PersistentState <$> newForeignPtr freePersistentState state @@ -242,9 +243,14 @@ emptyPersistentState = do -- (that is written to using the provided 'StoreCallback'). The input persistent -- state remains valid. The new persistent state is not cached, it is entirely -- stored on disk. -foreign import ccall "migrate_persistent_tree_v1" migratePersistentTree :: LoadCallback store -> StoreCallback store -> Ptr (ForeignPersistentState store) -> IO (Ptr (ForeignPersistentState store)) +foreign import ccall "migrate_persistent_tree_v1" + migratePersistentTree :: + LoadCallback store -> + StoreCallback store' -> + Ptr (ForeignPersistentState store) -> + IO (Ptr (ForeignPersistentState store')) -migratePersistentState :: LoadCallback store -> StoreCallback store -> PersistentState store -> IO (PersistentState store) +migratePersistentState :: LoadCallback store -> StoreCallback store' -> PersistentState store -> IO (PersistentState store') migratePersistentState lcbk scbk ps = do newPSPtr <- withPersistentState ps $ migratePersistentTree lcbk scbk newPS <- newForeignPtr freePersistentState newPSPtr diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Account.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Account.hs index 90ec727d56..eaa82dfe9b 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Account.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Account.hs @@ -52,8 +52,8 @@ data PersistentAccount store (av :: AccountVersion) where PAV1 :: !(V0.PersistentAccount store 'AccountV1) -> PersistentAccount store 'AccountV1 PAV2 :: !(V1.PersistentAccount store 'AccountV2) -> PersistentAccount store 'AccountV2 PAV3 :: !(V1.PersistentAccount store 'AccountV3) -> PersistentAccount store 'AccountV3 - PAV4 :: !(V1.PersistentAccount 'AccountV4) -> PersistentAccount 'AccountV4 - PAV5 :: !(V1.PersistentAccount 'AccountV5) -> PersistentAccount 'AccountV5 + PAV4 :: !(V1.PersistentAccount store 'AccountV4) -> PersistentAccount store 'AccountV4 + PAV5 :: !(V1.PersistentAccount store 'AccountV5) -> PersistentAccount store 'AccountV5 instance (MonadBlobStore m, store ~ MBSStore m) => MHashableTo m (AccountHash av) (PersistentAccount store av) where getHashM (PAV0 acc) = getHashM acc @@ -96,8 +96,8 @@ data PersistentBakerInfoRef store (av :: AccountVersion) where PBIRV1 :: !(V0.PersistentBakerInfoEx store 'AccountV1) -> PersistentBakerInfoRef store 'AccountV1 PBIRV2 :: !(V1.PersistentBakerInfoEx store 'AccountV2) -> PersistentBakerInfoRef store 'AccountV2 PBIRV3 :: !(V1.PersistentBakerInfoEx store 'AccountV3) -> PersistentBakerInfoRef store 'AccountV3 - PBIRV4 :: !(V1.PersistentBakerInfoEx 'AccountV4) -> PersistentBakerInfoRef 'AccountV4 - PBIRV5 :: !(V1.PersistentBakerInfoEx 'AccountV5) -> PersistentBakerInfoRef 'AccountV5 + PBIRV4 :: !(V1.PersistentBakerInfoEx store 'AccountV4) -> PersistentBakerInfoRef store 'AccountV4 + PBIRV5 :: !(V1.PersistentBakerInfoEx store 'AccountV5) -> PersistentBakerInfoRef store 'AccountV5 instance Show (PersistentBakerInfoRef store av) where show (PBIRV0 pibr) = show pibr @@ -375,7 +375,7 @@ accountHash (PAV5 acc) = getHashM acc -- versions that support protocol level tokens. accountTokens :: (MonadBlobStore m, AVSupportsPLT av) => - PersistentAccount av -> + PersistentAccount (MBSStore m) av -> m (Map.Map BlockState.TokenIndex BlockState.TokenAccountState) accountTokens (PAV5 acc) = uncond <$> V1.getTokenStateTable acc @@ -383,7 +383,7 @@ accountTokens (PAV5 acc) = uncond <$> V1.getTokenStateTable acc -- This is only available at account versions that support protocol-level tokens. accountTokenBalance :: (MonadBlobStore m, AVSupportsPLT av) => - PersistentAccount av -> + PersistentAccount (MBSStore m) av -> BlockState.TokenIndex -> m TokenRawAmount accountTokenBalance (PAV5 acc) = V1.getTokenBalance acc @@ -436,8 +436,8 @@ updateTokenAccountState :: -- | How to update the token account state if present (Just) and if not present (Nothing) in the token account state table. (Maybe BlockState.TokenAccountState -> m BlockState.TokenAccountState) -> -- | The account to update - PersistentAccount av -> - m (PersistentAccount av) + PersistentAccount (MBSStore m) av -> + m (PersistentAccount (MBSStore m) av) updateTokenAccountState tokenIx upd (PAV5 acc) = PAV5 <$> case V1.accountTokenStateTable acc of CTrue (Some ref) -> doUpdate ref @@ -604,8 +604,8 @@ setAccountStake newStake (PAV5 acc) = PAV5 <$> V1.setStake newStake acc setAccountValidatorSuspended :: (MonadBlobStore m, AVSupportsValidatorSuspension av) => Bool -> - PersistentAccount av -> - m (PersistentAccount av) + PersistentAccount (MBSStore m) av -> + m (PersistentAccount (MBSStore m) av) setAccountValidatorSuspended isSuspended (PAV4 acc) = PAV4 <$> V1.setValidatorSuspended isSuspended acc setAccountValidatorSuspended isSuspended (PAV5 acc) = PAV5 <$> V1.setValidatorSuspended isSuspended acc diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Account/MigrationState.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Account/MigrationState.hs index b5dddcaadf..7d0f44cadc 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Account/MigrationState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Account/MigrationState.hs @@ -6,6 +6,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} module Concordium.GlobalState.Persistent.Account.MigrationState where @@ -45,13 +46,13 @@ type IntroducesFlexibleCooldown (oldpv :: ProtocolVersion) (pv :: ProtocolVersio -- | State that is accumulated accross the migration of accounts from one protocol version to -- another. -data AccountMigrationState (oldpv :: ProtocolVersion) (pv :: ProtocolVersion) = AccountMigrationState +data AccountMigrationState store (oldpv :: ProtocolVersion) (pv :: ProtocolVersion) = AccountMigrationState { -- | In the P6 -> P7 protocol update, this records the accounts that previously were in -- cooldown, and now will be in pre-pre-cooldown. _migrationPrePreCooldown :: !( Conditionally (IntroducesFlexibleCooldown oldpv pv) - AccountList + (AccountList store) ), -- | When migrating P6->P7, we build up the 'PersistentActiveBakers' while -- traversing the account table. This should be initialised with the active bakers (that @@ -59,7 +60,7 @@ data AccountMigrationState (oldpv :: ProtocolVersion) (pv :: ProtocolVersion) = _persistentActiveBakers :: !( Conditionally (IntroducesFlexibleCooldown oldpv pv) - (PersistentActiveBakers (AccountVersionFor pv)) + (PersistentActiveBakers store (AccountVersionFor pv)) ), -- | A counter to track the index of the current account as we traverse the account table. _currentAccountIndex :: !AccountIndex @@ -77,18 +78,19 @@ makeLenses ''AccountMigrationState -- actually be removed as bakers. During the processing of the account table, the delegators -- will be added back to the 'PersistentActiveBakers' as they are encountered. initialPersistentActiveBakersForMigration :: - forall oldpv av t m. + forall oldstore store oldpv av t m. ( IsAccountVersion av, SupportMigration m t, - SupportsPersistentAccount oldpv m + store ~ MBSStore (t m), + SupportsPersistentAccount oldstore oldpv m ) => - Accounts oldpv -> - PersistentActiveBakers (AccountVersionFor oldpv) -> + Accounts oldstore oldpv -> + PersistentActiveBakers oldstore (AccountVersionFor oldpv) -> t m ( Conditionally (Not (SupportsFlexibleCooldown (AccountVersionFor oldpv)) && SupportsFlexibleCooldown av) - (PersistentActiveBakers av) + (PersistentActiveBakers store av) ) initialPersistentActiveBakersForMigration oldAccounts oldActiveBakers = case (oldSFC, newSFC) of (SFalse, SFalse) -> return CFalse @@ -97,7 +99,7 @@ initialPersistentActiveBakersForMigration oldAccounts oldActiveBakers = case (ol bakers <- lift $ Trie.keysAsc (oldActiveBakers ^. activeBakers) CTrue <$> foldM accumBakers emptyPersistentActiveBakers bakers where - accumBakers :: PersistentActiveBakers av -> BakerId -> t m (PersistentActiveBakers av) + accumBakers :: PersistentActiveBakers store av -> BakerId -> t m (PersistentActiveBakers store av) accumBakers pab bakerId = lift (indexedAccount (bakerAccountIndex bakerId) oldAccounts) >>= \case Nothing -> error "Baker account does not exist" @@ -134,13 +136,13 @@ initialPersistentActiveBakersForMigration oldAccounts oldActiveBakers = case (ol -- | An 'AccountMigrationState' in an initial state. initialAccountMigrationState :: - forall oldpv pv. + forall store oldpv pv. (IsProtocolVersion oldpv, IsProtocolVersion pv) => -- | The active bakers without the delegators. Conditionally (IntroducesFlexibleCooldown oldpv pv) - (PersistentActiveBakers (AccountVersionFor pv)) -> - AccountMigrationState oldpv pv + (PersistentActiveBakers store (AccountVersionFor pv)) -> + AccountMigrationState store oldpv pv initialAccountMigrationState _persistentActiveBakers = AccountMigrationState{..} where _migrationPrePreCooldown = case sSupportsFlexibleCooldown (accountVersion @(AccountVersionFor oldpv)) of @@ -155,13 +157,14 @@ initialAccountMigrationState _persistentActiveBakers = AccountMigrationState{..} makeInitialAccountMigrationState :: ( IsProtocolVersion pv, SupportMigration m t, - SupportsPersistentAccount oldpv m + store ~ MBSStore (t m), + SupportsPersistentAccount oldstore oldpv m ) => - Accounts oldpv -> - PersistentActiveBakers (AccountVersionFor oldpv) -> - t m (AccountMigrationState oldpv pv) + Accounts oldstore oldpv -> + PersistentActiveBakers oldstore (AccountVersionFor oldpv) -> + t m (AccountMigrationState store oldpv pv) makeInitialAccountMigrationState accounts pab = - initialAccountMigrationState <$> initialPersistentActiveBakersForMigration accounts pab + initialAccountMigrationState <$> (initialPersistentActiveBakersForMigration accounts pab) -- | A monad transformer transformer that left-composes @StateT (AccountMigrationState old pv)@ -- with a given monad transformer @t@. @@ -174,25 +177,38 @@ newtype (a :: Type) = AccountMigrationStateTT { runAccountMigrationStateTT' :: - StateT (AccountMigrationState oldpv pv) (t m) a + StateT (AccountMigrationState (MBSStore (t m)) oldpv pv) (t m) a } deriving newtype ( Functor, Applicative, Monad, - MonadState (AccountMigrationState oldpv pv), + -- MonadState (AccountMigrationState store oldpv pv), MonadIO, LMDBAccountMap.MonadAccountMapStore, MonadModuleMapStore, MonadLogger ) +type instance MBSStore (AccountMigrationStateTT oldpv pv t m) = MBSStore (t m) + +deriving via + forall + (oldpv :: ProtocolVersion) + (pv :: ProtocolVersion) + (t :: (Type -> Type) -> (Type -> Type)) + (m :: (Type -> Type)). + (StateT (AccountMigrationState (MBSStore (t m)) oldpv pv) (t m)) + instance + (Monad (t m), store ~ (MBSStore (t m))) => + (MonadState (AccountMigrationState store oldpv pv) (AccountMigrationStateTT oldpv pv t m)) + -- | Run an 'AccountMigrationStateTT' computation with the given initial state. -- This is used to add 'AccountMigration' and 'AccountsMigration' interfaces to the monad stack. runAccountMigrationStateTT :: AccountMigrationStateTT oldpv pv t m a -> - AccountMigrationState oldpv pv -> - t m (a, AccountMigrationState oldpv pv) + AccountMigrationState (MBSStore (t m)) oldpv pv -> + t m (a, AccountMigrationState (MBSStore (t m)) oldpv pv) runAccountMigrationStateTT = runStateT . runAccountMigrationStateTT' deriving via @@ -201,7 +217,7 @@ deriving via (pv :: ProtocolVersion) (t :: (Type -> Type) -> (Type -> Type)) (m :: (Type -> Type)). - (StateT (AccountMigrationState oldpv pv) (t m)) + (StateT (AccountMigrationState (MBSStore (t m)) oldpv pv) (t m)) instance (MonadBlobStore (t m)) => (MonadBlobStore (AccountMigrationStateTT oldpv pv t m)) @@ -212,7 +228,7 @@ deriving via (pv :: ProtocolVersion) (t :: (Type -> Type) -> (Type -> Type)) (m :: (Type -> Type)). - (StateT (AccountMigrationState oldpv pv) (t m)) + (StateT (AccountMigrationState (MBSStore (t m)) oldpv pv) (t m)) instance (MonadCache c (t m)) => (MonadCache c (AccountMigrationStateTT oldpv pv t m)) diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Account/ProtocolLevelTokens.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Account/ProtocolLevelTokens.hs index 560541aec5..9e0421cb20 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Account/ProtocolLevelTokens.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Account/ProtocolLevelTokens.hs @@ -23,12 +23,15 @@ import Concordium.GlobalState.Persistent.BlockState.ProtocolLevelTokens -- | The table of PLT account states. The table is indexed by the token index -- into the global token table. -newtype TokenAccountStateTable = TokenAccountStateTable - { tokenAccountStateTable :: Map.Map TokenIndex (HashedBufferedRef TokenAccountState) +newtype TokenAccountStateTable store = TokenAccountStateTable + { tokenAccountStateTable :: Map.Map TokenIndex (HashedBufferedRef store TokenAccountState) } deriving newtype (Show) -instance (MonadBlobStore m) => MHashableTo m TokenStateTableHash TokenAccountStateTable where +instance + (MonadBlobStore m, store ~ MBSStore m) => + MHashableTo m TokenStateTableHash (TokenAccountStateTable store) + where getHashM (TokenAccountStateTable tast) = do hashes <- mapM @@ -39,7 +42,10 @@ instance (MonadBlobStore m) => MHashableTo m TokenStateTableHash TokenAccountSta $ Map.toAscList tast return $ TokenStateTableHash $ hashAsLFMBTV1 emptyTokenAccountStateTableHash hashes -instance (MonadBlobStore m) => BlobStorable m TokenAccountStateTable where +instance + (MonadBlobStore m, store ~ MBSStore m) => + BlobStorable m (TokenAccountStateTable store) + where storeUpdate (TokenAccountStateTable tast) = do storeUpdatedMap <- mapM storeUpdate tast let putter = do @@ -56,7 +62,7 @@ instance (MonadBlobStore m) => BlobStorable m TokenAccountStateTable where return $ TokenAccountStateTable <$> sequenceA (Map.fromList l) -- | The empty token account state table. -emptyTokenAccountStateTable :: TokenAccountStateTable +emptyTokenAccountStateTable :: TokenAccountStateTable store emptyTokenAccountStateTable = TokenAccountStateTable{tokenAccountStateTable = Map.empty} -- | The empty token account state. @@ -68,16 +74,16 @@ emptyTokenAccountState = -- | Helper function to update a reference to a token account state table. updateTokenAccountStateTable :: - (MonadBlobStore m, Reference m ref TokenAccountStateTable) => + (MonadBlobStore m, Reference m (MBSStore m) ref (TokenAccountStateTable (MBSStore m))) => -- | The token account state table to update - ref TokenAccountStateTable -> + ref (TokenAccountStateTable (MBSStore m)) -> -- | The index of the token in question TokenIndex -> -- | How to create a new token account state if the token doesn't have a token account state associated yet m TokenAccountState -> -- | How to update an existing token account state (TokenAccountState -> m TokenAccountState) -> - m (ref TokenAccountStateTable) + m (ref (TokenAccountStateTable (MBSStore m))) updateTokenAccountStateTable ref tokIx createNewState updateExisting = do TokenAccountStateTable tst <- refLoad ref tst' <- @@ -99,8 +105,8 @@ updateTokenAccountStateTable ref tokIx createNewState updateExisting = do -- Note, this migration preseves hashing. migrateTokenAccountStateTable :: (SupportMigration m t) => - TokenAccountStateTable -> - t m TokenAccountStateTable + TokenAccountStateTable (MBSStore m) -> + t m (TokenAccountStateTable (MBSStore (t m))) migrateTokenAccountStateTable tast = do newTable <- mapM migrateHashedBufferedRefKeepHash (tokenAccountStateTable tast) return TokenAccountStateTable{tokenAccountStateTable = newTable} diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Account/StructureV1.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Account/StructureV1.hs index 36ae1a3c5e..5dad98dacf 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Account/StructureV1.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Account/StructureV1.hs @@ -237,8 +237,8 @@ migratePersistentAccountStakeEnduringAV4 :: AVSupportsValidatorSuspension av1, AVSupportsValidatorSuspension av2 ) => - PersistentAccountStakeEnduring av1 -> - t m (PersistentAccountStakeEnduring av2) + PersistentAccountStakeEnduring (MBSStore m) av1 -> + t m (PersistentAccountStakeEnduring (MBSStore (t m)) av2) migratePersistentAccountStakeEnduringAV4 PersistentAccountStakeEnduringNone = return PersistentAccountStakeEnduringNone migratePersistentAccountStakeEnduringAV4 PersistentAccountStakeEnduringBaker{..} = do @@ -394,9 +394,9 @@ migratePersistentAccountStakeEnduringV2toV3 PersistentAccountStakeEnduringDelega -- false. migratePersistentAccountStakeEnduringV3toV4 :: (SupportMigration m t, AccountMigration 'AccountV4 (t m)) => - PersistentAccountStakeEnduring 'AccountV3 -> + PersistentAccountStakeEnduring (MBSStore m) 'AccountV3 -> -- | Returns the new 'PersistentAccountStakeEnduring' and 'CooldownQueue'. - t m (PersistentAccountStakeEnduring 'AccountV4) + t m (PersistentAccountStakeEnduring (MBSStore (t m)) 'AccountV4) migratePersistentAccountStakeEnduringV3toV4 PersistentAccountStakeEnduringNone = return PersistentAccountStakeEnduringNone migratePersistentAccountStakeEnduringV3toV4 PersistentAccountStakeEnduringBaker{..} = do @@ -428,10 +428,10 @@ instance where getHashM stake = getHash <$> persistentToAccountStake stake 0 -instance (MonadBlobStore m) => MHashableTo m (AccountStakeHash 'AccountV4) (PersistentAccountStakeEnduring 'AccountV4) where +instance (MonadBlobStore m, store ~ MBSStore m) => MHashableTo m (AccountStakeHash 'AccountV4) (PersistentAccountStakeEnduring store 'AccountV4) where getHashM stake = getHash <$> persistentToAccountStake stake 0 -instance (MonadBlobStore m) => MHashableTo m (AccountStakeHash 'AccountV5) (PersistentAccountStakeEnduring 'AccountV5) where +instance (MonadBlobStore m, store ~ MBSStore m) => MHashableTo m (AccountStakeHash 'AccountV5) (PersistentAccountStakeEnduring store 'AccountV5) where getHashM stake = getHash <$> persistentToAccountStake stake 0 -- * Enduring account data @@ -553,12 +553,12 @@ makeAccountEnduringDataAV3 paedPersistingData paedEncryptedAmount paedReleaseSch -- and the total amount of the releases must be the provided amount. makeAccountEnduringDataAV4 :: (MonadBlobStore m) => - EagerBufferedRef PersistingAccountData -> - Nullable (LazyBufferedRef PersistentAccountEncryptedAmount) -> - Nullable (LazyBufferedRef AccountReleaseSchedule, Amount) -> - PersistentAccountStakeEnduring 'AccountV4 -> - CooldownQueue 'AccountV4 -> - m (PersistentAccountEnduringData 'AccountV4) + EagerBufferedRef (MBSStore m) PersistingAccountData -> + Nullable (LazyBufferedRef (MBSStore m) (PersistentAccountEncryptedAmount (MBSStore m))) -> + Nullable (LazyBufferedRef (MBSStore m) (AccountReleaseSchedule (MBSStore m)), Amount) -> + PersistentAccountStakeEnduring (MBSStore m) 'AccountV4 -> + CooldownQueue (MBSStore m) 'AccountV4 -> + m (PersistentAccountEnduringData (MBSStore m) 'AccountV4) makeAccountEnduringDataAV4 paedPersistingData paedEncryptedAmount paedReleaseSchedule paedStake paedStakeCooldown = do amhi4PersistingAccountDataHash <- getHashM paedPersistingData (amhi4AccountStakeHash :: AccountStakeHash 'AccountV4) <- getHashM paedStake @@ -584,12 +584,12 @@ makeAccountEnduringDataAV4 paedPersistingData paedEncryptedAmount paedReleaseSch -- and the total amount of the releases must be the provided amount. makeAccountEnduringDataAV5 :: (MonadBlobStore m) => - EagerBufferedRef PersistingAccountData -> - Nullable (LazyBufferedRef PersistentAccountEncryptedAmount) -> - Nullable (LazyBufferedRef AccountReleaseSchedule, Amount) -> - PersistentAccountStakeEnduring 'AccountV5 -> - CooldownQueue 'AccountV5 -> - m (PersistentAccountEnduringData 'AccountV5) + EagerBufferedRef (MBSStore m) PersistingAccountData -> + Nullable (LazyBufferedRef (MBSStore m) (PersistentAccountEncryptedAmount (MBSStore m))) -> + Nullable (LazyBufferedRef (MBSStore m) (AccountReleaseSchedule (MBSStore m)), Amount) -> + PersistentAccountStakeEnduring (MBSStore m) 'AccountV5 -> + CooldownQueue (MBSStore m) 'AccountV5 -> + m (PersistentAccountEnduringData (MBSStore m) 'AccountV5) makeAccountEnduringDataAV5 paedPersistingData paedEncryptedAmount paedReleaseSchedule paedStake paedStakeCooldown = do amhi5PersistingAccountDataHash <- getHashM paedPersistingData (amhi5AccountStakeHash :: AccountStakeHash 'AccountV5) <- getHashM paedStake @@ -644,8 +644,8 @@ rehashAccountEnduringDataAV3 ed = do rehashAccountEnduringDataAV4 :: (MonadBlobStore m) => - PersistentAccountEnduringData 'AccountV4 -> - m (PersistentAccountEnduringData 'AccountV4) + PersistentAccountEnduringData (MBSStore m) 'AccountV4 -> + m (PersistentAccountEnduringData (MBSStore m) 'AccountV4) rehashAccountEnduringDataAV4 ed = do amhi4PersistingAccountDataHash <- getHashM (paedPersistingData ed) (amhi4AccountStakeHash :: AccountStakeHash 'AccountV4) <- getHashM (paedStake ed) @@ -661,8 +661,8 @@ rehashAccountEnduringDataAV4 ed = do rehashAccountEnduringDataAV5 :: (MonadBlobStore m) => - PersistentAccountEnduringData 'AccountV5 -> - m (PersistentAccountEnduringData 'AccountV5) + PersistentAccountEnduringData (MBSStore m) 'AccountV5 -> + m (PersistentAccountEnduringData (MBSStore m) 'AccountV5) rehashAccountEnduringDataAV5 ed = do amhi5PersistingAccountDataHash <- getHashM (paedPersistingData ed) (amhi5AccountStakeHash :: AccountStakeHash 'AccountV5) <- getHashM (paedStake ed) @@ -1028,7 +1028,13 @@ data PersistentAccount store av = PersistentAccount -- INVARIANT: This is 0 if the account is not a baker or delegator. accountStakedAmount :: !Amount, -- | The state table of the protocol level tokens of the account in ascending order of the TokenIndex. - accountTokenStateTable :: !(Conditionally (SupportsPLT av) (Nullable (EagerlyHashedBufferedRef' TokenStateTableHash TokenAccountStateTable))), + accountTokenStateTable :: + !( Conditionally + (SupportsPLT av) + ( Nullable + (EagerlyHashedBufferedRef' TokenStateTableHash store (TokenAccountStateTable store)) + ) + ), -- | The enduring account data. accountEnduringData :: !(EagerBufferedRef store (PersistentAccountEnduringData store av)) } @@ -1068,9 +1074,9 @@ instance HashableTo (AccountHash 'AccountV4) (PersistentAccount store 'AccountV4 ahi2MerkleHash = getHash accountEnduringData } -instance (Monad m) => MHashableTo m (AccountHash 'AccountV3) (PersistentAccount 'AccountV3) -instance (Monad m) => MHashableTo m (AccountHash 'AccountV4) (PersistentAccount 'AccountV4) -instance (MonadBlobStore m) => MHashableTo m (AccountHash 'AccountV5) (PersistentAccount 'AccountV5) where +instance (Monad m) => MHashableTo m (AccountHash 'AccountV3) (PersistentAccount store 'AccountV3) +instance (Monad m) => MHashableTo m (AccountHash 'AccountV4) (PersistentAccount store 'AccountV4) +instance (MonadBlobStore m) => MHashableTo m (AccountHash 'AccountV5) (PersistentAccount store 'AccountV5) where getHashM PersistentAccount{..} = do h <- case uncond accountTokenStateTable of Null -> return $ TokenStateTableHash emptyTokenAccountStateTableHash @@ -1386,7 +1392,7 @@ getCooldowns = -- state table is not present, the empty map is returned. getTokenStateTable :: (MonadBlobStore m) => - PersistentAccount av -> + PersistentAccount (MBSStore m) av -> m (Conditionally (SupportsPLT av) (Map.Map TokenIndex TokenAccountState)) getTokenStateTable acc = forM (accountTokenStateTable acc) $ \case Null -> return Map.empty @@ -1398,7 +1404,7 @@ getTokenStateTable acc = forM (accountTokenStateTable acc) $ \case -- This is only available at account versions that support protocol-level tokens. getTokenBalance :: (MonadBlobStore m, AVSupportsPLT av) => - PersistentAccount av -> + PersistentAccount (MBSStore m) av -> TokenIndex -> m TokenRawAmount getTokenBalance acc tokenIx = do @@ -1674,8 +1680,8 @@ setValidatorSuspended :: AVSupportsValidatorSuspension av ) => Bool -> - PersistentAccount av -> - m (PersistentAccount av) + PersistentAccount (MBSStore m) av -> + m (PersistentAccount (MBSStore m) av) setValidatorSuspended isSusp = updateStake $ \case baker@PersistentAccountStakeEnduringBaker{} -> do oldInfo <- refLoad (paseBakerInfo baker) @@ -2187,9 +2193,9 @@ migrateEnduringDataV2toV3 ed = do migrateEnduringDataV3toV4 :: (SupportMigration m t, AccountMigration 'AccountV4 (t m), MonadLogger (t m)) => -- | Current enduring data - PersistentAccountEnduringData 'AccountV3 -> + PersistentAccountEnduringData (MBSStore m) 'AccountV3 -> -- | New enduring data. - t m (PersistentAccountEnduringData 'AccountV4) + t m (PersistentAccountEnduringData (MBSStore (t m)) 'AccountV4) migrateEnduringDataV3toV4 ed = do logEvent GlobalState LLTrace "Migrating persisting data" paedPersistingData <- migrateEagerBufferedRef return (paedPersistingData ed) @@ -2215,9 +2221,9 @@ migrateEnduringDataV3toV4 ed = do migrateEnduringDataV4toV5 :: (SupportMigration m t, MonadLogger (t m)) => -- | Current enduring data - PersistentAccountEnduringData 'AccountV4 -> + PersistentAccountEnduringData (MBSStore m) 'AccountV4 -> -- | New enduring data. - t m (PersistentAccountEnduringData 'AccountV5) + t m (PersistentAccountEnduringData (MBSStore (t m)) 'AccountV5) migrateEnduringDataV4toV5 ed = do logEvent GlobalState LLTrace "Migrating persisting data" paedPersistingData <- migrateEagerBufferedRef return (paedPersistingData ed) @@ -2260,8 +2266,8 @@ migrateEnduringDataV3toV3 ed = do -- The data is unchanged in the migration. migrateEnduringDataV4toV4 :: (SupportMigration m t) => - PersistentAccountEnduringData 'AccountV4 -> - t m (PersistentAccountEnduringData 'AccountV4) + PersistentAccountEnduringData (MBSStore m) 'AccountV4 -> + t m (PersistentAccountEnduringData (MBSStore (t m)) 'AccountV4) migrateEnduringDataV4toV4 ed = do paedPersistingData <- migrateEagerBufferedRef return (paedPersistingData ed) paedEncryptedAmount <- forM (paedEncryptedAmount ed) $ migrateReference migratePersistentEncryptedAmount @@ -2276,8 +2282,8 @@ migrateEnduringDataV4toV4 ed = do -- The data is unchanged in the migration. migrateEnduringDataV5toV5 :: (SupportMigration m t) => - PersistentAccountEnduringData 'AccountV5 -> - t m (PersistentAccountEnduringData 'AccountV5) + PersistentAccountEnduringData (MBSStore m) 'AccountV5 -> + t m (PersistentAccountEnduringData (MBSStore (t m)) 'AccountV5) migrateEnduringDataV5toV5 ed = do paedPersistingData <- migrateEagerBufferedRef return (paedPersistingData ed) paedEncryptedAmount <- forM (paedEncryptedAmount ed) $ migrateReference migratePersistentEncryptedAmount @@ -2376,8 +2382,8 @@ migrateV3ToV4 :: MonadTrans t, MonadLogger (t m) ) => - PersistentAccount 'AccountV3 -> - t m (PersistentAccount 'AccountV4) + PersistentAccount (MBSStore m) 'AccountV3 -> + t m (PersistentAccount (MBSStore (t m)) 'AccountV4) migrateV3ToV4 acc = do accountEnduringData <- migrateEagerBufferedRef migrateEnduringDataV3toV4 (accountEnduringData acc) return $! @@ -2396,8 +2402,8 @@ migrateV4ToV4 :: MonadBlobStore (t m), MonadTrans t ) => - PersistentAccount 'AccountV4 -> - t m (PersistentAccount 'AccountV4) + PersistentAccount (MBSStore m) 'AccountV4 -> + t m (PersistentAccount (MBSStore (t m)) 'AccountV4) migrateV4ToV4 acc = do accountEnduringData <- migrateEagerBufferedRef migrateEnduringDataV4toV4 (accountEnduringData acc) return $! @@ -2415,8 +2421,8 @@ migrateV4ToV5 :: MonadTrans t, MonadLogger (t m) ) => - PersistentAccount 'AccountV4 -> - t m (PersistentAccount 'AccountV5) + PersistentAccount (MBSStore m) 'AccountV4 -> + t m (PersistentAccount (MBSStore (t m)) 'AccountV5) migrateV4ToV5 acc = do accountEnduringData <- migrateEagerBufferedRef migrateEnduringDataV4toV5 (accountEnduringData acc) return $! @@ -2435,8 +2441,8 @@ migrateV5ToV5 :: MonadBlobStore (t m), MonadTrans t ) => - PersistentAccount 'AccountV5 -> - t m (PersistentAccount 'AccountV5) + PersistentAccount (MBSStore m) 'AccountV5 -> + t m (PersistentAccount (MBSStore (t m)) 'AccountV5) migrateV5ToV5 acc = do accountEnduringData <- migrateEagerBufferedRef migrateEnduringDataV5toV5 (accountEnduringData acc) accountTokenStateTable <- diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs index e2ce07ddfb..40e1e11fe8 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs @@ -570,8 +570,11 @@ migrateAccounts :: t m (Accounts store2 pv) migrateAccounts migration Accounts{..} = do logEvent GlobalState LLTrace "Migrating accounts" - let migrateAccount acct = do - canonicalAddress <- accountCanonicalAddress =<< lift (refLoad acct) + let migrateAccount :: + HashedCachedRef store1 (AccountCache store1 (AccountVersionFor oldpv)) (PersistentAccount store1 (AccountVersionFor oldpv)) -> + t m (HashedCachedRef store2 (AccountCache store2 (AccountVersionFor pv)) (PersistentAccount store2 (AccountVersionFor pv))) + migrateAccount acct = do + canonicalAddress <- lift (accountCanonicalAddress =<< refLoad acct) logEvent GlobalState LLTrace $ "Migrating account: " <> show canonicalAddress newAcct <- migrateHashedCachedRef' (migratePersistentAccount migration) acct -- Increment the account index counter. diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Bakers.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Bakers.hs index 94ef038e5b..d705008b08 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Bakers.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Bakers.hs @@ -46,8 +46,8 @@ import Concordium.Utils.Serialization.Put -- $Concordium.GlobalState.Persistent.Account.PersistentAccountCacheable for details.) -newtype BakerInfos (pv :: ProtocolVersion) - = BakerInfos (Vec.Vector (PersistentBakerInfoRef (AccountVersionFor pv))) +newtype BakerInfos store (pv :: ProtocolVersion) + = BakerInfos (Vec.Vector (PersistentBakerInfoRef store (AccountVersionFor pv))) deriving (Show) -- | See documentation of @migratePersistentBlockState@. @@ -57,11 +57,14 @@ migrateBakerInfos :: SupportMigration m t ) => StateMigrationParameters oldpv pv -> - BakerInfos oldpv -> - t m (BakerInfos pv) + BakerInfos (MBSStore m) oldpv -> + t m (BakerInfos (MBSStore (t m)) pv) migrateBakerInfos migration (BakerInfos inner) = BakerInfos <$> mapM (migratePersistentBakerInfoRef migration) inner -instance (IsProtocolVersion pv, MonadBlobStore m) => BlobStorable m (BakerInfos pv) where +instance + (IsProtocolVersion pv, MonadBlobStore m, store ~ MBSStore m) => + BlobStorable m (BakerInfos store pv) + where storeUpdate (BakerInfos v) = do v' <- mapM storeUpdate v let pv = do @@ -74,7 +77,11 @@ instance (IsProtocolVersion pv, MonadBlobStore m) => BlobStorable m (BakerInfos return $ BakerInfos <$> sequence v -- | This hashing should match (part of) the hashing for 'Basic.EpochBakers'. -instance forall pv m. (IsProtocolVersion pv, MonadBlobStore m) => MHashableTo m H.Hash (BakerInfos pv) where +instance + forall store pv m. + (IsProtocolVersion pv, MonadBlobStore m, store ~ MBSStore m) => + MHashableTo m H.Hash (BakerInfos store pv) + where getHashM (BakerInfos infos) = do loadedInfos <- mapM loadPersistentBakerInfoRef infos case sBlockHashVersionFor (protocolVersion @pv) of @@ -83,7 +90,7 @@ instance forall pv m. (IsProtocolVersion pv, MonadBlobStore m) => MHashableTo m SBlockHashVersion1 -> do return $ hashAsLFMBTV1 (H.hash "NoBakerInfos") $ H.hashLazy . runPutLazy . put <$> Vec.toList loadedInfos -instance (Applicative m) => Cacheable m (BakerInfos av) +instance (Applicative m) => Cacheable m (BakerInfos store pv) -- | A list of stakes for bakers. newtype BakerStakes = BakerStakes (Vec.Vector Amount) deriving (Show) @@ -107,9 +114,9 @@ instance (Applicative m) => Cacheable m BakerStakes -- | The set of bakers that are eligible to bake in a particular epoch. -- -- The hashing scheme separately hashes the baker info and baker stakes. -data PersistentEpochBakers (pv :: ProtocolVersion) = PersistentEpochBakers - { _bakerInfos :: !(HashedBufferedRef (BakerInfos pv)), - _bakerStakes :: !(HashedBufferedRef BakerStakes), +data PersistentEpochBakers store (pv :: ProtocolVersion) = PersistentEpochBakers + { _bakerInfos :: !(HashedBufferedRef store (BakerInfos store pv)), + _bakerStakes :: !(HashedBufferedRef store BakerStakes), _bakerTotalStake :: !Amount, _bakerFinalizationCommitteeParameters :: !(OFinalizationCommitteeParameters pv) } @@ -120,7 +127,9 @@ makeLenses ''PersistentEpochBakers -- | Extract the list of pairs of (baker id, staked amount). The list is ordered -- by increasing 'BakerId'. -- The intention is that the list will be consumed immediately. -extractBakerStakes :: (IsProtocolVersion pv, MonadBlobStore m) => PersistentEpochBakers pv -> m [(BakerId, Amount)] +extractBakerStakes :: + (IsProtocolVersion pv, MonadBlobStore m) => + PersistentEpochBakers (MBSStore m) pv -> m [(BakerId, Amount)] extractBakerStakes PersistentEpochBakers{..} = do BakerInfos infos <- refLoad _bakerInfos BakerStakes stakes <- refLoad _bakerStakes @@ -140,8 +149,8 @@ migratePersistentEpochBakers :: SupportMigration m t ) => StateMigrationParameters oldpv pv -> - PersistentEpochBakers oldpv -> - t m (PersistentEpochBakers pv) + PersistentEpochBakers (MBSStore m) oldpv -> + t m (PersistentEpochBakers (MBSStore (t m)) pv) migratePersistentEpochBakers migration PersistentEpochBakers{..} = do newBakerInfos <- migrateHashedBufferedRef (migrateBakerInfos migration) _bakerInfos newBakerStakes <- migrateHashedBufferedRefKeepHash _bakerStakes @@ -174,7 +183,7 @@ epochBaker :: forall m pv. (IsProtocolVersion pv, MonadBlobStore m) => BakerId -> - PersistentEpochBakers pv -> + PersistentEpochBakers (MBSStore m) pv -> m (Maybe (BaseAccounts.BakerInfoEx (AccountVersionFor pv), Amount)) epochBaker bid PersistentEpochBakers{..} = do (BakerInfos infoVec) <- refLoad _bakerInfos @@ -184,7 +193,9 @@ epochBaker bid PersistentEpochBakers{..} = do return (binfo, stakeVec Vec.! idx) -- | Serialize 'PersistentEpochBakers'. -putEpochBakers :: (IsProtocolVersion pv, MonadBlobStore m, MonadPut m) => PersistentEpochBakers pv -> m () +putEpochBakers :: + (IsProtocolVersion pv, MonadBlobStore m, MonadPut m) => + PersistentEpochBakers (MBSStore m) pv -> m () putEpochBakers peb = do BakerInfos bi <- refLoad (peb ^. bakerInfos) bInfos <- mapM loadBakerInfo bi @@ -196,7 +207,10 @@ putEpochBakers peb = do mapM_ (liftPut . put) bStakes mapM_ (liftPut . put) (peb ^. bakerFinalizationCommitteeParameters) -instance (IsProtocolVersion pv, MonadBlobStore m) => MHashableTo m H.Hash (PersistentEpochBakers pv) where +instance + (IsProtocolVersion pv, MonadBlobStore m, store ~ MBSStore m) => + MHashableTo m H.Hash (PersistentEpochBakers store pv) + where getHashM PersistentEpochBakers{..} = do hbkrInfos :: H.Hash <- getHashM _bakerInfos hbkrStakes :: H.Hash <- getHashM _bakerStakes @@ -210,7 +224,10 @@ instance (IsProtocolVersion pv, MonadBlobStore m) => MHashableTo m H.Hash (Persi (H.hashOfHashes hbkrInfos hbkrStakes) (getHash params) -instance (IsProtocolVersion pv, MonadBlobStore m) => BlobStorable m (PersistentEpochBakers pv) where +instance + (IsProtocolVersion pv, MonadBlobStore m, store ~ MBSStore m) => + BlobStorable m (PersistentEpochBakers store pv) + where storeUpdate PersistentEpochBakers{..} = do (pBkrInfos, newBkrInfos) <- storeUpdate _bakerInfos (pBkrStakes, newBkrStakes) <- storeUpdate _bakerStakes @@ -230,14 +247,19 @@ instance (IsProtocolVersion pv, MonadBlobStore m) => BlobStorable m (PersistentE _bakerStakes <- mBkrStakes return PersistentEpochBakers{..} -instance (IsProtocolVersion pv, MonadBlobStore m) => Cacheable m (PersistentEpochBakers pv) where +instance + (IsProtocolVersion pv, MonadBlobStore m, store ~ MBSStore m) => + Cacheable m (PersistentEpochBakers store pv) + where cache peb = do cBkrInfos <- cache (_bakerInfos peb) cBkrStakes <- cache (_bakerStakes peb) return peb{_bakerInfos = cBkrInfos, _bakerStakes = cBkrStakes} -- | Derive a 'FullBakers' from a 'PersistentEpochBakers'. -epochToFullBakers :: (IsProtocolVersion pv, MonadBlobStore m) => PersistentEpochBakers pv -> m FullBakers +epochToFullBakers :: + (IsProtocolVersion pv, MonadBlobStore m) => + PersistentEpochBakers (MBSStore m) pv -> m FullBakers epochToFullBakers PersistentEpochBakers{..} = do BakerInfos infoRefs <- refLoad _bakerInfos infos <- mapM loadBakerInfo infoRefs @@ -254,7 +276,7 @@ epochToFullBakers PersistentEpochBakers{..} = do epochToFullBakersEx :: forall m pv. (MonadBlobStore m, IsProtocolVersion pv, PVSupportsDelegation pv) => - PersistentEpochBakers pv -> + PersistentEpochBakers (MBSStore m) pv -> m FullBakersEx epochToFullBakersEx PersistentEpochBakers{..} = do BakerInfos infoRefs <- refLoad _bakerInfos @@ -270,25 +292,25 @@ epochToFullBakersEx PersistentEpochBakers{..} = do mkFullBakerInfoEx (BaseAccounts.BakerInfoExV1 info extra _isSuspended) stake = FullBakerInfoEx (FullBakerInfo info stake) (extra ^. BaseAccounts.poolCommissionRates) -type DelegatorIdTrieSet = Trie.TrieN BufferedFix DelegatorId () +type DelegatorIdTrieSet store = Trie.TrieN (BufferedFix store) DelegatorId () -type BakerIdTrieMap av = Trie.TrieN BufferedFix BakerId (PersistentActiveDelegators av) +type BakerIdTrieMap store av = Trie.TrieN (BufferedFix store) BakerId (PersistentActiveDelegators store av) -- | The set of delegators to a particular pool. -- For 'AccountV0', delegation is not supported, and this is essentially the unit type. -data PersistentActiveDelegators (av :: AccountVersion) where - PersistentActiveDelegatorsV0 :: PersistentActiveDelegators 'AccountV0 +data PersistentActiveDelegators store (av :: AccountVersion) where + PersistentActiveDelegatorsV0 :: PersistentActiveDelegators store 'AccountV0 PersistentActiveDelegatorsV1 :: (AVSupportsDelegation av) => { -- | The set of delegators to this pool. - adDelegators :: !DelegatorIdTrieSet, + adDelegators :: !(DelegatorIdTrieSet store), -- | The total capital of the delegators to this pool. adDelegatorTotalCapital :: !Amount } -> - PersistentActiveDelegators av + PersistentActiveDelegators store av -- | Lens to access the total capital of the delegators to the pool. -delegatorTotalCapital :: (AVSupportsDelegation av) => Lens' (PersistentActiveDelegators av) Amount +delegatorTotalCapital :: (AVSupportsDelegation av) => Lens' (PersistentActiveDelegators store av) Amount delegatorTotalCapital f (PersistentActiveDelegatorsV1{..}) = (\newDTC -> PersistentActiveDelegatorsV1{adDelegatorTotalCapital = newDTC, ..}) <$> f adDelegatorTotalCapital @@ -300,8 +322,8 @@ delegatorTotalCapital f (PersistentActiveDelegatorsV1{..}) = migratePersistentActiveDelegators :: (BlobStorable m (), BlobStorable (t m) (), MonadTrans t) => StateMigrationParameters oldpv pv -> - PersistentActiveDelegators (AccountVersionFor oldpv) -> - t m (PersistentActiveDelegators (AccountVersionFor pv)) + PersistentActiveDelegators (MBSStore m) (AccountVersionFor oldpv) -> + t m (PersistentActiveDelegators (MBSStore (t m)) (AccountVersionFor pv)) migratePersistentActiveDelegators StateMigrationParametersTrivial = \case PersistentActiveDelegatorsV0 -> return PersistentActiveDelegatorsV0 PersistentActiveDelegatorsV1{..} -> do @@ -343,17 +365,17 @@ migratePersistentActiveDelegators StateMigrationParametersP9ToP10{} = \case newDelegators <- Trie.migrateTrieN True return adDelegators return PersistentActiveDelegatorsV1{adDelegators = newDelegators, ..} -emptyPersistentActiveDelegators :: forall av. (IsAccountVersion av) => PersistentActiveDelegators av +emptyPersistentActiveDelegators :: forall store av. (IsAccountVersion av) => PersistentActiveDelegators store av emptyPersistentActiveDelegators = case delegationSupport @av of SAVDelegationNotSupported -> PersistentActiveDelegatorsV0 SAVDelegationSupported -> PersistentActiveDelegatorsV1 Trie.empty 0 -deriving instance Show (PersistentActiveDelegators av) +deriving instance Show (PersistentActiveDelegators store av) -- | This instance cases on the account version (hence the @IsAccountVersion av@ constraint). -- The storage for each version is thus essentially independent. -instance (IsAccountVersion av, MonadBlobStore m) => BlobStorable m (PersistentActiveDelegators av) where +instance (IsAccountVersion av, MonadBlobStore m, store ~ MBSStore m) => BlobStorable m (PersistentActiveDelegators store av) where storeUpdate PersistentActiveDelegatorsV0 = return (return (), PersistentActiveDelegatorsV0) storeUpdate PersistentActiveDelegatorsV1{..} = do @@ -417,18 +439,18 @@ subtractActiveCapital amt0 (TotalActiveCapitalV1 amt1) = TotalActiveCapitalV1 $ tacAmount :: (AVSupportsDelegation av) => Lens' (TotalActiveCapital av) Amount tacAmount f (TotalActiveCapitalV1 amt) = TotalActiveCapitalV1 <$> f amt -type AggregationKeySet = Trie.TrieN BufferedFix BakerAggregationVerifyKey () +type AggregationKeySet store = Trie.TrieN (BufferedFix store) BakerAggregationVerifyKey () -- | Persistent representation of the state of the active bakers and delegators. -data PersistentActiveBakers (av :: AccountVersion) = PersistentActiveBakers +data PersistentActiveBakers store (av :: AccountVersion) = PersistentActiveBakers { -- | For each active baker, this records the set of delegators and their total stake. -- (This does not include the baker's own stake.) - _activeBakers :: !(BakerIdTrieMap av), + _activeBakers :: !(BakerIdTrieMap store av), -- | The set of aggregation keys of all active bakers. -- This is used to prevent duplicate aggregation keys from being deployed. - _aggregationKeys :: !AggregationKeySet, + _aggregationKeys :: !(AggregationKeySet store), -- | The set of delegators to the passive pool, with their total stake. - _passiveDelegators :: !(PersistentActiveDelegators av), + _passiveDelegators :: !(PersistentActiveDelegators store av), -- | The total capital staked by all bakers and delegators. _totalActiveCapital :: !(TotalActiveCapital av) } @@ -447,13 +469,13 @@ migratePersistentActiveBakers :: ( IsProtocolVersion oldpv, IsProtocolVersion pv, SupportMigration m t, - Accounts.SupportsPersistentAccount pv (t m) + Accounts.SupportsPersistentAccount (MBSStore (t m)) pv (t m) ) => StateMigrationParameters oldpv pv -> -- | Already migrated accounts. - Accounts.Accounts pv -> - PersistentActiveBakers (AccountVersionFor oldpv) -> - t m (PersistentActiveBakers (AccountVersionFor pv)) + Accounts.Accounts (MBSStore (t m)) pv -> + PersistentActiveBakers (MBSStore m) (AccountVersionFor oldpv) -> + t m (PersistentActiveBakers (MBSStore (t m)) (AccountVersionFor pv)) migratePersistentActiveBakers migration accounts PersistentActiveBakers{..} = do newActiveBakers <- Trie.migrateTrieN True (migratePersistentActiveDelegators migration) _activeBakers newAggregationKeys <- Trie.migrateTrieN True return _aggregationKeys @@ -481,7 +503,7 @@ migratePersistentActiveBakers migration accounts PersistentActiveBakers{..} = do } -- | Construct a 'PersistentActiveBakers' with no bakers or delegators. -emptyPersistentActiveBakers :: forall av. (IsAccountVersion av) => PersistentActiveBakers av +emptyPersistentActiveBakers :: forall store av. (IsAccountVersion av) => PersistentActiveBakers store av emptyPersistentActiveBakers = case delegationSupport @av of SAVDelegationSupported -> PersistentActiveBakers @@ -498,7 +520,7 @@ emptyPersistentActiveBakers = case delegationSupport @av of _totalActiveCapital = TotalActiveCapitalV0 } -totalActiveCapitalV1 :: (AVSupportsDelegation av) => Lens' (PersistentActiveBakers av) Amount +totalActiveCapitalV1 :: (AVSupportsDelegation av) => Lens' (PersistentActiveBakers store av) Amount totalActiveCapitalV1 = totalActiveCapital . tac where tac :: (AVSupportsDelegation av) => Lens' (TotalActiveCapital av) Amount @@ -510,8 +532,8 @@ addDelegatorHelper :: (MonadBlobStore m, AVSupportsDelegation av) => DelegatorId -> Amount -> - PersistentActiveDelegators av -> - m (PersistentActiveDelegators av) + PersistentActiveDelegators (MBSStore m) av -> + m (PersistentActiveDelegators (MBSStore m) av) addDelegatorHelper did amt (PersistentActiveDelegatorsV1 dset tot) = do newDset <- Trie.insert did () dset return $ PersistentActiveDelegatorsV1 newDset (tot + amt) @@ -528,8 +550,8 @@ addDelegator :: DelegationTarget -> DelegatorId -> Amount -> - PersistentActiveBakers av -> - m (Either BakerId (PersistentActiveBakers av)) + PersistentActiveBakers (MBSStore m) av -> + m (Either BakerId (PersistentActiveBakers (MBSStore m) av)) addDelegator DelegatePassive did amt pab = Right <$> passiveDelegators (addDelegatorHelper did amt) pab addDelegator (DelegateToBaker bid) did amt pab = @@ -550,8 +572,8 @@ addDelegatorUnsafe :: DelegationTarget -> DelegatorId -> Amount -> - PersistentActiveBakers av -> - m (PersistentActiveBakers av) + PersistentActiveBakers (MBSStore m) av -> + m (PersistentActiveBakers (MBSStore m) av) addDelegatorUnsafe DelegatePassive did amt = passiveDelegators (addDelegatorHelper did amt) addDelegatorUnsafe (DelegateToBaker bid) did amt = activeBakers (fmap snd . Trie.adjust upd bid) where @@ -564,8 +586,8 @@ removeDelegatorHelper :: (MonadBlobStore m, AVSupportsDelegation av) => DelegatorId -> Amount -> - PersistentActiveDelegators av -> - m (PersistentActiveDelegators av) + PersistentActiveDelegators (MBSStore m) av -> + m (PersistentActiveDelegators (MBSStore m) av) removeDelegatorHelper did amt (PersistentActiveDelegatorsV1 dset tot) = do newDset <- Trie.delete did dset return $ PersistentActiveDelegatorsV1 newDset (tot - amt) @@ -579,8 +601,8 @@ removeDelegator :: DelegationTarget -> DelegatorId -> Amount -> - PersistentActiveBakers av -> - m (PersistentActiveBakers av) + PersistentActiveBakers (MBSStore m) av -> + m (PersistentActiveBakers (MBSStore m) av) removeDelegator DelegatePassive did amt pab = passiveDelegators (removeDelegatorHelper did amt) pab removeDelegator (DelegateToBaker bid) did amt pab = do let rdh Nothing = return ((), Trie.NoChange) @@ -597,8 +619,8 @@ modifyPoolCapitalUnsafe :: (MonadBlobStore m, IsAccountVersion av, AVSupportsDelegation av) => DelegationTarget -> (Amount -> Amount) -> - PersistentActiveBakers av -> - m (PersistentActiveBakers av) + PersistentActiveBakers (MBSStore m) av -> + m (PersistentActiveBakers (MBSStore m) av) modifyPoolCapitalUnsafe DelegatePassive change = pure . (passiveDelegators . delegatorTotalCapital %~ change) modifyPoolCapitalUnsafe (DelegateToBaker bid) change = @@ -614,8 +636,8 @@ modifyPoolCapitalUnsafe (DelegateToBaker bid) change = transferDelegatorsToPassive :: (MonadBlobStore m, IsAccountVersion av, AVSupportsDelegation av) => BakerId -> - PersistentActiveBakers av -> - m ([DelegatorId], PersistentActiveBakers av) + PersistentActiveBakers (MBSStore m) av -> + m ([DelegatorId], PersistentActiveBakers (MBSStore m) av) transferDelegatorsToPassive bid pab = do (transferred, newAB) <- Trie.adjust extract bid (pab ^. activeBakers) transList <- Trie.keysAsc (adDelegators transferred) @@ -634,8 +656,8 @@ transferDelegatorsToPassive bid pab = do extract (Just t) = return (t, Trie.Insert emptyPersistentActiveDelegators) instance - (IsAccountVersion av, MonadBlobStore m) => - BlobStorable m (PersistentActiveBakers av) + (IsAccountVersion av, MonadBlobStore m, store ~ MBSStore m) => + BlobStorable m (PersistentActiveBakers store av) where storeUpdate oldPAB@PersistentActiveBakers{..} = do (pActiveBakers, newActiveBakers) <- storeUpdate _activeBakers @@ -660,4 +682,4 @@ instance _passiveDelegators <- mpassiveDelegators return PersistentActiveBakers{..} -instance (IsAccountVersion av, Applicative m) => Cacheable m (PersistentActiveBakers av) +instance (IsAccountVersion av, Applicative m) => Cacheable m (PersistentActiveBakers store av) diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlobStore.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlobStore.hs index 9e06547a81..412410d9f6 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlobStore.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlobStore.hs @@ -177,6 +177,7 @@ import Concordium.Wasm import qualified Concordium.Crypto.SHA256 as H import qualified Concordium.GlobalState.AccountMap.LMDB as LMDBAccountMap import Concordium.GlobalState.AccountMap.ModuleMap (MonadModuleMapStore) +import Concordium.GlobalState.Classes (MGSTrans) import Concordium.Types.HashableTo -- | A @BlobRef store a@ represents an offset on a file, at @@ -523,6 +524,8 @@ readBlobPtrBS bs@BlobStoreAccess{..} bptr@BlobPtr{..} = do -- | The associated store type for a monad. type family MBSStore (m :: Type -> Type) +type instance MBSStore (MGSTrans t m) = MBSStore m + -- | Typeclass for a monad to be equipped with a blob store. -- This allows a 'BS.ByteString' to be written to the store, -- obtaining a 'BlobRef', and a 'BlobRef' to be read back as @@ -614,10 +617,10 @@ deriving via LMDBAccountMap.MonadAccountMapStore (BlobStoreT store r m) deriving via - (LMDBAccountMap.AccountMapStoreMonad (BlobStoreT r m)) + (LMDBAccountMap.AccountMapStoreMonad (BlobStoreT store r m)) instance (MonadIO m, MonadLogger m, LMDBAccountMap.HasDatabaseHandlers r) => - MonadModuleMapStore (BlobStoreT r m) + MonadModuleMapStore (BlobStoreT store r m) -- | Apply a given function to modify the context of a 'BlobStoreT' operation. alterBlobStoreT :: (r1 -> r2) -> BlobStoreT store r2 m a -> BlobStoreT store r1 m a @@ -675,6 +678,7 @@ deriving via instance (MonadBlobStore m) => MonadBlobStore (ExceptT e m) +type instance MBSStore (MaybeT m) = MBSStore m deriving via (LiftMonadBlobStore MaybeT m) instance @@ -909,7 +913,7 @@ class (MonadBlobStore m) => DirectBlobHashable m h a where -- | Load the hash of a value of type @a@ from the underlying storage. -- -- prop> loadHash = getHashM <=< loadDirect - loadHash :: BlobRef a -> m h + loadHash :: BlobRef (MBSStore m) a -> m h instance {-# OVERLAPPABLE #-} diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs index 4482b3d9e5..a4c74df751 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs @@ -137,13 +137,13 @@ import System.Directory (removeDirectoryRecursive) -- * Birk parameters -data PersistentBirkParameters (pv :: ProtocolVersion) = PersistentBirkParameters +data PersistentBirkParameters store (pv :: ProtocolVersion) = PersistentBirkParameters { -- | The currently-registered bakers. - _birkActiveBakers :: !(BufferedRef (PersistentActiveBakers (AccountVersionFor pv))), + _birkActiveBakers :: !(BufferedRef store (PersistentActiveBakers store (AccountVersionFor pv))), -- | The bakers that will be used for the next epoch. - _birkNextEpochBakers :: !(HashedBufferedRef (PersistentEpochBakers pv)), + _birkNextEpochBakers :: !(HashedBufferedRef store (PersistentEpochBakers store pv)), -- | The bakers for the current epoch. - _birkCurrentEpochBakers :: !(HashedBufferedRef (PersistentEpochBakers pv)), + _birkCurrentEpochBakers :: !(HashedBufferedRef store (PersistentEpochBakers store pv)), -- | The seed state used to derive the leadership election nonce. _birkSeedState :: !(SeedState (SeedStateVersionFor pv)) } @@ -216,17 +216,17 @@ migrateSeedStateV1Trivial SeedStateV1{..} = -- -- Migrate the birk parameters assuming accounts have already been migrated. migratePersistentBirkParameters :: - forall c oldpv pv t m. + forall store c oldpv pv t m. ( IsProtocolVersion pv, IsProtocolVersion oldpv, SupportMigration m t, - SupportsPersistentAccount pv (t m) + SupportsPersistentAccount store pv (t m) ) => StateMigrationParameters oldpv pv -> - Accounts.Accounts pv -> - Conditionally c (PersistentActiveBakers (AccountVersionFor pv)) -> - PersistentBirkParameters oldpv -> - t m (PersistentBirkParameters pv) + Accounts.Accounts store pv -> + Conditionally c (PersistentActiveBakers store (AccountVersionFor pv)) -> + PersistentBirkParameters (MBSStore m) oldpv -> + t m (PersistentBirkParameters store pv) migratePersistentBirkParameters migration accounts mActiveBakers PersistentBirkParameters{..} = do newActiveBakers <- case mActiveBakers of CTrue ab -> refMake ab @@ -243,17 +243,17 @@ migratePersistentBirkParameters migration accounts mActiveBakers PersistentBirkP -- | Accumulated state when iterating accounts, meant for constructing PersistentBirkParameters. -- Used internally by initialBirkParameters. -data IBPFromAccountsAccum av = IBPFromAccountsAccum +data IBPFromAccountsAccum store av = IBPFromAccountsAccum { -- | Collection of the IDs of the active bakers. - aibpBakerIds :: !(BakerIdTrieMap av), + aibpBakerIds :: !(BakerIdTrieMap store av), -- | Collection of the aggregation keys of the active bakers. - aibpBakerKeys :: !AggregationKeySet, + aibpBakerKeys :: !(AggregationKeySet store), -- | Total amount owned by accounts. aibpTotal :: !Amount, -- | Total staked amount by bakers. aibpStakedTotal :: !Amount, -- | List of baker info refs in incremental order of the baker ID. - aibpBakerInfoRefs :: !(Vec.Vector (PersistentBakerInfoRef av)), + aibpBakerInfoRefs :: !(Vec.Vector (PersistentBakerInfoRef store av)), -- | List of baker stake in incremental order of the baker ID. -- Entries in this list should have a matching entry in agsBakerCapitals. -- In the end result these are needed separately and are therefore constructed separately. @@ -261,7 +261,7 @@ data IBPFromAccountsAccum av = IBPFromAccountsAccum } -- | Initial state for iterating accounts. -initialIBPFromAccountsAccum :: IBPFromAccountsAccum pv +initialIBPFromAccountsAccum :: IBPFromAccountsAccum store pv initialIBPFromAccountsAccum = IBPFromAccountsAccum { aibpBakerIds = Trie.empty, @@ -274,15 +274,15 @@ initialIBPFromAccountsAccum = -- | Collections of delegators, grouped by the pool they are delegating to. -- Used internally by initialBirkParameters. -data IBPCollectedDelegators av = IBPCollectedDelegators +data IBPCollectedDelegators store av = IBPCollectedDelegators { -- | Delegators delegating to the passive pool. - ibpcdToPassive :: !(PersistentActiveDelegators av), + ibpcdToPassive :: !(PersistentActiveDelegators store av), -- | Delegators delegating to bakers - ibpcdToBaker :: !(Map.Map BakerId (PersistentActiveDelegators av)) + ibpcdToBaker :: !(Map.Map BakerId (PersistentActiveDelegators store av)) } -- | Empty collections of delegators. -emptyIBPCollectedDelegators :: (IsAccountVersion av) => IBPCollectedDelegators av +emptyIBPCollectedDelegators :: (IsAccountVersion av) => IBPCollectedDelegators store av emptyIBPCollectedDelegators = IBPCollectedDelegators { ibpcdToPassive = emptyPersistentActiveDelegators, @@ -294,12 +294,12 @@ initialBirkParameters :: forall pv av m. (MonadBlobStore m, IsProtocolVersion pv, av ~ AccountVersionFor pv) => -- | The accounts in ascending order of the account index. - [PersistentAccount av] -> + [PersistentAccount (MBSStore m) av] -> -- | The seed state SeedState (SeedStateVersionFor pv) -> -- | The finalization committee parameters (if relevant) OFinalizationCommitteeParameters pv -> - m (PersistentBirkParameters pv) + m (PersistentBirkParameters (MBSStore m) pv) initialBirkParameters accounts seedState _bakerFinalizationCommitteeParameters = do -- Iterate accounts and collect delegators. IBPCollectedDelegators{..} <- case delegationSupport @av of @@ -344,9 +344,9 @@ initialBirkParameters accounts seedState _bakerFinalizationCommitteeParameters = -- If the account is delegating, add it to the collection. collectDelegator :: (AVSupportsDelegation av) => - IBPCollectedDelegators av -> - PersistentAccount av -> - m (IBPCollectedDelegators av) + IBPCollectedDelegators (MBSStore m) av -> + PersistentAccount (MBSStore m) av -> + m (IBPCollectedDelegators (MBSStore m) av) collectDelegator accum account = do maybeDelegation <- accountDelegator account case maybeDelegation of @@ -372,10 +372,10 @@ initialBirkParameters accounts seedState _bakerFinalizationCommitteeParameters = -- Add account information to the state accumulator. accumFromAccounts :: - Map.Map BakerId (PersistentActiveDelegators av) -> - IBPFromAccountsAccum av -> - PersistentAccount av -> - m (IBPFromAccountsAccum av) + Map.Map BakerId (PersistentActiveDelegators (MBSStore m) av) -> + IBPFromAccountsAccum (MBSStore m) av -> + PersistentAccount (MBSStore m) av -> + m (IBPFromAccountsAccum (MBSStore m) av) accumFromAccounts delegatorMap accum account = do publicBalance <- accountAmount account let !updatedAccum = accum{aibpTotal = aibpTotal accum + publicBalance} @@ -403,7 +403,10 @@ initialBirkParameters accounts seedState _bakerFinalizationCommitteeParameters = } Nothing -> return updatedAccum -freezeContractState :: forall v m. (Wasm.IsWasmVersion v, MonadBlobStore m) => UpdatableContractState v -> m (H.Hash, Instances.InstanceStateV v) +freezeContractState :: + forall v m. + (Wasm.IsWasmVersion v, MonadBlobStore m) => + UpdatableContractState (MBSStore m) v -> m (H.Hash, Instances.InstanceStateV (MBSStore m) v) freezeContractState cs = case Wasm.getWasmVersion @v of Wasm.SV0 -> return (getHash cs, Instances.InstanceStateV0 cs) Wasm.SV1 -> do @@ -411,7 +414,10 @@ freezeContractState cs = case Wasm.getWasmVersion @v of (hsh, persistent) <- liftIO (StateV1.freeze cbk cs) return (hsh, Instances.InstanceStateV1 persistent) -instance (IsProtocolVersion pv, MonadBlobStore m) => MHashableTo m H.Hash (PersistentBirkParameters pv) where +instance + (IsProtocolVersion pv, MonadBlobStore m, store ~ MBSStore m) => + MHashableTo m H.Hash (PersistentBirkParameters store pv) + where getHashM PersistentBirkParameters{..} = withIsSeedStateVersionFor (protocolVersion @pv) $ do nextHash <- getHashM _birkNextEpochBakers currentHash <- getHashM _birkCurrentEpochBakers @@ -419,7 +425,10 @@ instance (IsProtocolVersion pv, MonadBlobStore m) => MHashableTo m H.Hash (Persi bpH1 = H.hashOfHashes nextHash currentHash return $ H.hashOfHashes bpH0 bpH1 -instance (MonadBlobStore m, IsProtocolVersion pv) => BlobStorable m (PersistentBirkParameters pv) where +instance + (MonadBlobStore m, IsProtocolVersion pv, store ~ MBSStore m) => + BlobStorable m (PersistentBirkParameters store pv) + where storeUpdate bps@PersistentBirkParameters{..} = withIsSeedStateVersionFor (protocolVersion @pv) $ do (pabs, actBakers) <- storeUpdate _birkActiveBakers (pnebs, nextBakers) <- storeUpdate _birkNextEpochBakers @@ -448,7 +457,10 @@ instance (MonadBlobStore m, IsProtocolVersion pv) => BlobStorable m (PersistentB _birkCurrentEpochBakers <- mcebs return PersistentBirkParameters{..} -instance (MonadBlobStore m, IsProtocolVersion pv) => Cacheable m (PersistentBirkParameters pv) where +instance + (MonadBlobStore m, IsProtocolVersion pv, store ~ MBSStore m) => + Cacheable m (PersistentBirkParameters store pv) + where cache PersistentBirkParameters{..} = do activeBaks <- cache _birkActiveBakers next <- cache _birkNextEpochBakers @@ -463,18 +475,23 @@ instance (MonadBlobStore m, IsProtocolVersion pv) => Cacheable m (PersistentBirk -- * Epoch baked blocks -type EpochBlocks = Nullable (BufferedRef EpochBlock) +type EpochBlocks store = Nullable (BufferedRef store (EpochBlock store)) -- | Structure for tracking which bakers have baked blocks -- in the current epoch. -data EpochBlock = EpochBlock +data EpochBlock store = EpochBlock { ebBakerId :: !BakerId, - ebPrevious :: !EpochBlocks + ebPrevious :: !(EpochBlocks store) } -- | Migrate the 'EpochBlocks' structure, reading it from context @m@ and writing -- it to context @t m@. -migrateEpochBlocks :: (MonadTrans t, BlobStorable m EpochBlock, BlobStorable (t m) EpochBlock) => EpochBlocks -> t m EpochBlocks +migrateEpochBlocks :: + ( MonadTrans t, + BlobStorable m (EpochBlock (MBSStore m)), + BlobStorable (t m) (EpochBlock (MBSStore (t m))) + ) => + EpochBlocks (MBSStore m) -> t m (EpochBlocks (MBSStore (t m))) migrateEpochBlocks Null = return Null migrateEpochBlocks (Some inner) = Some <$> migrateReference go inner where @@ -484,7 +501,7 @@ migrateEpochBlocks (Some inner) = Some <$> migrateReference go inner -- | Return a map, mapping baker ids to the number of blocks they baked as they -- appear in the 'EpochBlocks' structure. -bakersFromEpochBlocks :: (MonadBlobStore m) => EpochBlocks -> m (Map.Map BakerId Word64) +bakersFromEpochBlocks :: (MonadBlobStore m) => EpochBlocks (MBSStore m) -> m (Map.Map BakerId Word64) bakersFromEpochBlocks = go Map.empty where go m Null = return m @@ -493,7 +510,7 @@ bakersFromEpochBlocks = go Map.empty let !m' = m & at ebBakerId . non 0 +~ 1 go m' ebPrevious -instance (MonadBlobStore m) => BlobStorable m EpochBlock where +instance (MonadBlobStore m, store ~ MBSStore m) => BlobStorable m (EpochBlock store) where storeUpdate eb@EpochBlock{..} = do (ppref, ebPrevious') <- storeUpdate ebPrevious let putEB = put ebBakerId >> ppref @@ -506,20 +523,20 @@ instance (MonadBlobStore m) => BlobStorable m EpochBlock where ebPrevious <- mPrevious return EpochBlock{..} -instance (MonadBlobStore m) => Cacheable m EpochBlock where +instance (MonadBlobStore m, store ~ MBSStore m) => Cacheable m (EpochBlock store) where cache eb = do ebPrevious' <- cache (ebPrevious eb) return eb{ebPrevious = ebPrevious'} -instance (MonadBlobStore m) => MHashableTo m Rewards.EpochBlocksHash EpochBlock where +instance (MonadBlobStore m, store ~ MBSStore m) => MHashableTo m Rewards.EpochBlocksHash (EpochBlock store) where getHashM EpochBlock{..} = Rewards.epochBlockHash ebBakerId <$> getHashM ebPrevious -instance (MonadBlobStore m) => MHashableTo m Rewards.EpochBlocksHash EpochBlocks where +instance (MonadBlobStore m, store ~ MBSStore m) => MHashableTo m Rewards.EpochBlocksHash (EpochBlocks store) where getHashM Null = return Rewards.emptyEpochBlocksHash getHashM (Some r) = getHashM r -data HashedEpochBlocks = HashedEpochBlocks - { hebBlocks :: !EpochBlocks, +data HashedEpochBlocks store = HashedEpochBlocks + { hebBlocks :: !(EpochBlocks store), hebHash :: !Rewards.EpochBlocksHash } @@ -527,7 +544,12 @@ data HashedEpochBlocks = HashedEpochBlocks -- that the hash does not change upon migration and so it is carried over. -- -- See also documentation of @migratePersistentBlockState@. -migrateHashedEpochBlocks :: (MonadTrans t, BlobStorable m EpochBlock, BlobStorable (t m) EpochBlock) => HashedEpochBlocks -> t m HashedEpochBlocks +migrateHashedEpochBlocks :: + ( MonadTrans t, + BlobStorable m (EpochBlock (MBSStore m)), + BlobStorable (t m) (EpochBlock (MBSStore (t m))) + ) => + HashedEpochBlocks (MBSStore m) -> t m (HashedEpochBlocks (MBSStore (t m))) migrateHashedEpochBlocks HashedEpochBlocks{..} = do newHebBlocks <- migrateEpochBlocks hebBlocks return @@ -536,10 +558,10 @@ migrateHashedEpochBlocks HashedEpochBlocks{..} = do .. } -instance HashableTo Rewards.EpochBlocksHash HashedEpochBlocks where +instance HashableTo Rewards.EpochBlocksHash (HashedEpochBlocks store) where getHash = hebHash -instance (MonadBlobStore m) => BlobStorable m HashedEpochBlocks where +instance (MonadBlobStore m, store ~ MBSStore m) => BlobStorable m (HashedEpochBlocks store) where storeUpdate heb = do (pblocks, blocks') <- storeUpdate (hebBlocks heb) return $!! (pblocks, heb{hebBlocks = blocks'}) @@ -550,13 +572,13 @@ instance (MonadBlobStore m) => BlobStorable m HashedEpochBlocks where hebHash <- getHashM hebBlocks return HashedEpochBlocks{..} -instance (MonadBlobStore m) => Cacheable m HashedEpochBlocks where +instance (MonadBlobStore m, store ~ MBSStore m) => Cacheable m (HashedEpochBlocks store) where cache red = do blocks' <- cache (hebBlocks red) return $! red{hebBlocks = blocks'} -- | The empty 'HashedEpochBlocks'. -emptyHashedEpochBlocks :: HashedEpochBlocks +emptyHashedEpochBlocks :: HashedEpochBlocks store emptyHashedEpochBlocks = HashedEpochBlocks { hebBlocks = Null, @@ -564,7 +586,11 @@ emptyHashedEpochBlocks = } -- | Add a new 'BakerId' to the start of a 'HashedEpochBlocks'. -consEpochBlock :: (MonadBlobStore m) => BakerId -> HashedEpochBlocks -> m HashedEpochBlocks +consEpochBlock :: + (MonadBlobStore m) => + BakerId -> + HashedEpochBlocks (MBSStore m) -> + m (HashedEpochBlocks (MBSStore m)) consEpochBlock b hebbs = do mbr <- refMake @@ -578,11 +604,13 @@ consEpochBlock b hebbs = do hebHash = Rewards.epochBlockHash b (hebHash hebbs) } -data BlockRewardDetails' (av :: AccountVersion) (bhv :: BlockHashVersion) where - BlockRewardDetailsV0 :: !HashedEpochBlocks -> BlockRewardDetails' 'AccountV0 bhv - BlockRewardDetailsV1 :: (AVSupportsDelegation av) => !(HashedBufferedRef' (Rewards.PoolRewardsHash bhv) (PoolRewards bhv av)) -> BlockRewardDetails' av bhv +data BlockRewardDetails' store (av :: AccountVersion) (bhv :: BlockHashVersion) where + BlockRewardDetailsV0 :: !(HashedEpochBlocks store) -> BlockRewardDetails' store 'AccountV0 bhv + BlockRewardDetailsV1 :: + (AVSupportsDelegation av) => + !(HashedBufferedRef' (Rewards.PoolRewardsHash bhv) store (PoolRewards store bhv av)) -> BlockRewardDetails' store av bhv -type BlockRewardDetails pv = BlockRewardDetails' (AccountVersionFor pv) (BlockHashVersionFor pv) +type BlockRewardDetails store pv = BlockRewardDetails' store (AccountVersionFor pv) (BlockHashVersionFor pv) -- | Migrate the block reward details. -- When migrating to 'P4' or 'P5', or from 'P5' to 'P6', this sets the 'nextPaydayEpoch' to the @@ -592,7 +620,7 @@ migrateBlockRewardDetails :: forall t m oldpv pv. ( MonadBlobStore (t m), MonadTrans t, - SupportsPersistentAccount oldpv m + SupportsPersistentAccount (MBSStore m) oldpv m ) => StateMigrationParameters oldpv pv -> -- | Current epoch bakers and stakes, in ascending order of 'BakerId'. @@ -603,8 +631,8 @@ migrateBlockRewardDetails :: OParam 'PTTimeParameters (ChainParametersVersionFor pv) TimeParameters -> -- | The epoch number before the protocol update. Epoch -> - BlockRewardDetails oldpv -> - t m (BlockRewardDetails pv) + BlockRewardDetails (MBSStore m) oldpv -> + t m (BlockRewardDetails (MBSStore (t m)) pv) migrateBlockRewardDetails StateMigrationParametersTrivial _ _ tp oldEpoch = \case (BlockRewardDetailsV0 heb) -> BlockRewardDetailsV0 <$> migrateHashedEpochBlocks heb (BlockRewardDetailsV1 hbr) -> case tp of @@ -620,7 +648,7 @@ migrateBlockRewardDetails StateMigrationParametersP2P3 _ _ _ _ = \case (BlockRewardDetailsV0 heb) -> BlockRewardDetailsV0 <$> migrateHashedEpochBlocks heb migrateBlockRewardDetails (StateMigrationParametersP3ToP4 _) curBakers nextBakers (SomeParam TimeParametersV1{..}) _ = \case (BlockRewardDetailsV0 heb) -> do - blockCounts <- bakersFromEpochBlocks (hebBlocks heb) + blockCounts <- lift $ bakersFromEpochBlocks (hebBlocks heb) (!newRef, _) <- refFlush =<< refMake =<< migratePoolRewardsP1 curBakers nextBakers blockCounts (rewardPeriodEpochs _tpRewardPeriodLength) _tpMintPerPayday return (BlockRewardDetailsV1 newRef) migrateBlockRewardDetails StateMigrationParametersP4ToP5{} _ _ (SomeParam TimeParametersV1{..}) _ = \case @@ -649,20 +677,23 @@ migrateBlockRewardDetails StateMigrationParametersP9ToP10{} _ _ (SomeParam TimeP <$> migrateHashedBufferedRef (migratePoolRewardsP6 oldEpoch _tpRewardPeriodLength) hbr instance - (MonadBlobStore m, IsBlockHashVersion bhv, IsAccountVersion av) => - MHashableTo m (Rewards.BlockRewardDetailsHash' av bhv) (BlockRewardDetails' av bhv) + (MonadBlobStore m, IsBlockHashVersion bhv, IsAccountVersion av, store ~ MBSStore m) => + MHashableTo m (Rewards.BlockRewardDetailsHash' av bhv) (BlockRewardDetails' store av bhv) where getHashM (BlockRewardDetailsV0 heb) = return $ Rewards.BlockRewardDetailsHashV0 (getHash heb) getHashM (BlockRewardDetailsV1 pr) = Rewards.BlockRewardDetailsHashV1 <$> getHashM pr -instance (IsAccountVersion av, MonadBlobStore m) => BlobStorable m (BlockRewardDetails' av bhv) where +instance (IsAccountVersion av, MonadBlobStore m, store ~ MBSStore m) => BlobStorable m (BlockRewardDetails' store av bhv) where storeUpdate (BlockRewardDetailsV0 heb) = fmap (fmap BlockRewardDetailsV0) $ storeUpdate heb storeUpdate (BlockRewardDetailsV1 hpr) = fmap (fmap BlockRewardDetailsV1) $ storeUpdate hpr load = case delegationSupport @av of SAVDelegationNotSupported -> fmap (fmap BlockRewardDetailsV0) load SAVDelegationSupported -> fmap (fmap BlockRewardDetailsV1) load -instance (MonadBlobStore m, IsBlockHashVersion bhv, IsAccountVersion av) => Cacheable m (BlockRewardDetails' av bhv) where +instance + (MonadBlobStore m, IsBlockHashVersion bhv, IsAccountVersion av, store ~ MBSStore m) => + Cacheable m (BlockRewardDetails' store av bhv) + where cache (BlockRewardDetailsV0 heb) = BlockRewardDetailsV0 <$> cache heb cache (BlockRewardDetailsV1 hpr) = BlockRewardDetailsV1 <$> cache hpr @@ -670,8 +701,8 @@ instance (MonadBlobStore m, IsBlockHashVersion bhv, IsAccountVersion av) => Cach consBlockRewardDetails :: (MonadBlobStore m) => BakerId -> - BlockRewardDetails' 'AccountV0 bhv -> - m (BlockRewardDetails' 'AccountV0 bhv) + BlockRewardDetails' (MBSStore m) 'AccountV0 bhv -> + m (BlockRewardDetails' (MBSStore m) 'AccountV0 bhv) consBlockRewardDetails bid (BlockRewardDetailsV0 heb) = do BlockRewardDetailsV0 <$> consEpochBlock bid heb @@ -679,7 +710,7 @@ consBlockRewardDetails bid (BlockRewardDetailsV0 heb) = do emptyBlockRewardDetails :: forall av bhv m. (MonadBlobStore m, IsAccountVersion av, IsBlockHashVersion bhv) => - m (BlockRewardDetails' av bhv) + m (BlockRewardDetails' (MBSStore m) av bhv) emptyBlockRewardDetails = case delegationSupport @av of SAVDelegationNotSupported -> return $ BlockRewardDetailsV0 emptyHashedEpochBlocks @@ -690,19 +721,20 @@ emptyBlockRewardDetails = -- | Type representing a persistent block state. This is a 'BufferedRef' inside an 'IORef', -- which supports making changes to the state without them (necessarily) being written to -- disk. -type PersistentBlockState (pv :: ProtocolVersion) = IORef (BufferedRef (BlockStatePointers pv)) +type PersistentBlockState store (pv :: ProtocolVersion) = + IORef (BufferedRef store (BlockStatePointers store pv)) -- | Transaction outcomes stored in a merkle binary tree. -data MerkleTransactionOutcomes (tov :: TransactionOutcomesVersion) = MerkleTransactionOutcomes +data MerkleTransactionOutcomes store (tov :: TransactionOutcomesVersion) = MerkleTransactionOutcomes { -- | Normal transaction outcomes - mtoOutcomes :: LFMBT.LFMBTree TransactionIndex HashedBufferedRef (TransactionSummaryV1 tov), + mtoOutcomes :: LFMBT.LFMBTree TransactionIndex (HashedBufferedRef store) (TransactionSummaryV1 tov), -- | Special transaction outcomes - mtoSpecials :: LFMBT.LFMBTree TransactionIndex HashedBufferedRef Transactions.SpecialTransactionOutcome + mtoSpecials :: LFMBT.LFMBTree TransactionIndex (HashedBufferedRef store) Transactions.SpecialTransactionOutcome } deriving (Show) -- | Create an empty 'MerkleTransactionOutcomes' -emptyMerkleTransactionOutcomes :: MerkleTransactionOutcomes tov +emptyMerkleTransactionOutcomes :: MerkleTransactionOutcomes store tov emptyMerkleTransactionOutcomes = MerkleTransactionOutcomes { mtoOutcomes = LFMBT.empty, @@ -719,14 +751,17 @@ emptyMerkleTransactionOutcomes = -- In PV5 and onwards the exact 'RejectReason's are omitted from the computed hash and moreover -- the hashing scheme is not a hash list but a merkle tree, so it is the root hash that is -- used in the final 'BlockHash'. -data PersistentTransactionOutcomes (tov :: TransactionOutcomesVersion) where - PTOV0 :: TransactionOutcomes.TransactionOutcomes 'TOV0 -> PersistentTransactionOutcomes 'TOV0 - PTOV1 :: MerkleTransactionOutcomes 'TOV1 -> PersistentTransactionOutcomes 'TOV1 - PTOV2 :: MerkleTransactionOutcomes 'TOV2 -> PersistentTransactionOutcomes 'TOV2 - PTOV3 :: MerkleTransactionOutcomes 'TOV3 -> PersistentTransactionOutcomes 'TOV3 +data PersistentTransactionOutcomes store (tov :: TransactionOutcomesVersion) where + PTOV0 :: TransactionOutcomes.TransactionOutcomes 'TOV0 -> PersistentTransactionOutcomes store 'TOV0 + PTOV1 :: MerkleTransactionOutcomes store 'TOV1 -> PersistentTransactionOutcomes store 'TOV1 + PTOV2 :: MerkleTransactionOutcomes store 'TOV2 -> PersistentTransactionOutcomes store 'TOV2 + PTOV3 :: MerkleTransactionOutcomes store 'TOV3 -> PersistentTransactionOutcomes store 'TOV3 -- | Create an empty persistent transaction outcome -emptyPersistentTransactionOutcomes :: forall tov. (IsTransactionOutcomesVersion tov) => PersistentTransactionOutcomes tov +emptyPersistentTransactionOutcomes :: + forall store tov. + (IsTransactionOutcomesVersion tov) => + PersistentTransactionOutcomes store tov emptyPersistentTransactionOutcomes = case transactionOutcomesVersion @tov of STOV0 -> PTOV0 TransactionOutcomes.emptyTransactionOutcomesV0 STOV1 -> PTOV1 emptyMerkleTransactionOutcomes @@ -734,8 +769,8 @@ emptyPersistentTransactionOutcomes = case transactionOutcomesVersion @tov of STOV3 -> PTOV3 emptyMerkleTransactionOutcomes instance - (BlobStorable m (TransactionSummaryV1 tov), MonadProtocolVersion m, (TransactionOutcomesVersionFor (MPV m) ~ tov)) => - MHashableTo m (TransactionOutcomes.TransactionOutcomesHashV tov) (PersistentTransactionOutcomes tov) + (BlobStorable m (TransactionSummaryV1 tov), MonadProtocolVersion m, (TransactionOutcomesVersionFor (MPV m) ~ tov), store ~ MBSStore m) => + MHashableTo m (TransactionOutcomes.TransactionOutcomesHashV tov) (PersistentTransactionOutcomes store tov) where getHashM (PTOV0 bto) = return (getHash bto) getHashM (PTOV1 MerkleTransactionOutcomes{..}) = do @@ -762,9 +797,10 @@ instance instance ( TransactionOutcomesVersionFor (MPV m) ~ tov, MonadBlobStore m, - MonadProtocolVersion m + MonadProtocolVersion m, + store ~ MBSStore m ) => - BlobStorable m (PersistentTransactionOutcomes tov) + BlobStorable m (PersistentTransactionOutcomes store tov) where storeUpdate out@(PTOV0 bto) = return (TransactionOutcomes.putTransactionOutcomes bto, out) storeUpdate out = case out of @@ -806,10 +842,10 @@ instance -- | Create an empty 'PersistentTransactionOutcomes' based on the 'ProtocolVersion'. emptyTransactionOutcomes :: - forall pv. + forall store pv. (SupportsTransactionOutcomes pv) => Proxy pv -> - PersistentTransactionOutcomes (TransactionOutcomesVersionFor pv) + PersistentTransactionOutcomes store (TransactionOutcomesVersionFor pv) emptyTransactionOutcomes Proxy = case transactionOutcomesVersion @(TransactionOutcomesVersionFor pv) of STOV0 -> PTOV0 TransactionOutcomes.emptyTransactionOutcomesV0 STOV1 -> PTOV1 emptyMerkleTransactionOutcomes @@ -823,55 +859,65 @@ emptyTransactionOutcomes Proxy = case transactionOutcomesVersion @(TransactionOu -- similar across versions. Where component change between versions, -- those components themselves should be parametrised by the protocol -- version. -data BlockStatePointers (pv :: ProtocolVersion) = BlockStatePointers - { bspAccounts :: !(Accounts.Accounts pv), - bspInstances :: !(Instances.Instances pv), - bspModules :: !(HashedBufferedRef' (ModulesHash pv) Modules.Modules), +data BlockStatePointers store (pv :: ProtocolVersion) = BlockStatePointers + { bspAccounts :: !(Accounts.Accounts store pv), + bspInstances :: !(Instances.Instances store pv), + bspModules :: !(HashedBufferedRef' (ModulesHash pv) store (Modules.Modules store)), bspBank :: !(Hashed Rewards.BankStatus), - bspIdentityProviders :: !(HashedBufferedRef IPS.IdentityProviders), - bspAnonymityRevokers :: !(HashedBufferedRef ARS.AnonymityRevokers), - bspBirkParameters :: !(PersistentBirkParameters pv), - bspCryptographicParameters :: !(HashedBufferedRef CryptographicParameters), - bspUpdates :: !(BufferedRef (Updates pv)), - bspReleaseSchedule :: !(ReleaseSchedule pv), - bspAccountsInCooldown :: !(AccountsInCooldownForPV pv), - bspTransactionOutcomes :: !(PersistentTransactionOutcomes (TransactionOutcomesVersionFor pv)), + bspIdentityProviders :: !(HashedBufferedRef store IPS.IdentityProviders), + bspAnonymityRevokers :: !(HashedBufferedRef store ARS.AnonymityRevokers), + bspBirkParameters :: !(PersistentBirkParameters store pv), + bspCryptographicParameters :: !(HashedBufferedRef store CryptographicParameters), + bspUpdates :: !(BufferedRef store (Updates store pv)), + bspReleaseSchedule :: !(ReleaseSchedule store pv), + bspAccountsInCooldown :: !(AccountsInCooldownForPV store pv), + bspTransactionOutcomes :: !(PersistentTransactionOutcomes store (TransactionOutcomesVersionFor pv)), -- | Details of bakers that baked blocks in the current epoch. This is -- used for rewarding bakers at the end of epochs. - bspRewardDetails :: !(BlockRewardDetails pv), + bspRewardDetails :: !(BlockRewardDetails store pv), -- | The global state of protocol-level tokens. - bspProtocolLevelTokens :: !(PLT.ProtocolLevelTokensForPV pv) + bspProtocolLevelTokens :: !(PLT.ProtocolLevelTokensForPV store pv) } -- | Lens for accessing the birk parameters of a 'BlockStatePointers' structure. -birkParameters :: Lens' (BlockStatePointers pv) (PersistentBirkParameters pv) +birkParameters :: Lens' (BlockStatePointers store pv) (PersistentBirkParameters store pv) birkParameters = lens bspBirkParameters (\bsp bp -> bsp{bspBirkParameters = bp}) -- | A hashed version of 'PersistingBlockState'. This is used when the block state -- is not being mutated so that the hash values are not recomputed constantly. -data HashedPersistentBlockState pv = HashedPersistentBlockState - { hpbsPointers :: !(PersistentBlockState pv), +data HashedPersistentBlockState store pv = HashedPersistentBlockState + { hpbsPointers :: !(PersistentBlockState store pv), hpbsHash :: !StateHash } -instance HashableTo StateHash (HashedPersistentBlockState pv) where +instance HashableTo StateHash (HashedPersistentBlockState store pv) where getHash = hpbsHash -instance (Monad m) => MHashableTo m StateHash (HashedPersistentBlockState pv) +instance (Monad m) => MHashableTo m StateHash (HashedPersistentBlockState store pv) -- | Constraint for ensuring that @m@ supports both persistent accounts and persistent modules. -type SupportsPersistentState pv m = (MonadProtocolVersion m, MPV m ~ pv, SupportsPersistentAccount pv m, Modules.SupportsPersistentModule m) +type SupportsPersistentState store pv m = + ( MonadProtocolVersion m, + MPV m ~ pv, + SupportsPersistentAccount store pv m, + Modules.SupportsPersistentModule m + ) -- | Convert a 'PersistentBlockState' to a 'HashedPersistentBlockState' by computing -- the state hash. -hashBlockState :: (SupportsPersistentState pv m) => PersistentBlockState pv -> m (HashedPersistentBlockState pv) +hashBlockState :: + (SupportsPersistentState store pv m) => + PersistentBlockState store pv -> m (HashedPersistentBlockState store pv) hashBlockState hpbsPointers = do rbsp <- liftIO $ readIORef hpbsPointers bsp <- refLoad rbsp hpbsHash <- getHashM bsp return HashedPersistentBlockState{..} -instance (SupportsPersistentState pv m) => MHashableTo m StateHash (BlockStatePointers pv) where +instance + (SupportsPersistentState store pv m) => + MHashableTo m StateHash (BlockStatePointers store pv) + where getHashM BlockStatePointers{..} = do bshBirkParameters <- getHashM bspBirkParameters bshCryptographicParameters <- getHashM bspCryptographicParameters @@ -886,7 +932,7 @@ instance (SupportsPersistentState pv m) => MHashableTo m StateHash (BlockStatePo bshProtocolLevelTokens <- getHashM bspProtocolLevelTokens return $ makeBlockStateHash @pv BlockStateHashInputs{..} -instance (SupportsPersistentState pv m) => BlobStorable m (BlockStatePointers pv) where +instance (SupportsPersistentState store pv m) => BlobStorable m (BlockStatePointers store pv) where storeUpdate bsp0@BlockStatePointers{..} = do (paccts, bspAccounts') <- storeUpdate bspAccounts (pinsts, bspInstances') <- storeUpdate bspInstances @@ -968,8 +1014,8 @@ instance (SupportsPersistentState pv m) => BlobStorable m (BlockStatePointers pv -- | Accessor for getting the pool rewards when supported by the protocol version. bspPoolRewards :: (PVSupportsDelegation pv, bhv ~ BlockHashVersionFor pv) => - BlockStatePointers pv -> - HashedBufferedRef' (Rewards.PoolRewardsHash bhv) (PoolRewards bhv (AccountVersionFor pv)) + BlockStatePointers store pv -> + HashedBufferedRef' (Rewards.PoolRewardsHash bhv) store (PoolRewards store bhv (AccountVersionFor pv)) bspPoolRewards bsp = case bspRewardDetails bsp of BlockRewardDetailsV1 pr -> pr @@ -977,16 +1023,16 @@ bspPoolRewards bsp = case bspRewardDetails bsp of -- This assumes that among the initial accounts, none are in (pre)*cooldown. {-# WARNING initialPersistentState "should only be used for testing" #-} initialPersistentState :: - forall pv m. - (SupportsPersistentState pv m) => + forall store pv m. + (SupportsPersistentState store pv m) => SeedState (SeedStateVersionFor pv) -> CryptographicParameters -> - [PersistentAccount (AccountVersionFor pv)] -> + [PersistentAccount store (AccountVersionFor pv)] -> IPS.IdentityProviders -> ARS.AnonymityRevokers -> UpdateKeysCollection (AuthorizationsVersionFor pv) -> ChainParameters pv -> - m (HashedPersistentBlockState pv) + m (HashedPersistentBlockState store pv) initialPersistentState seedState cryptoParams accounts ips ars keysCollection chainParams = do persistentBirkParameters <- initialBirkParameters accounts seedState (chainParams ^. cpFinalizationCommitteeParameters) modules <- refMake =<< Modules.emptyModules @@ -1024,13 +1070,13 @@ initialPersistentState seedState cryptoParams accounts ips ars keysCollection ch -- | A mostly empty block state, but with the given birk parameters, -- cryptographic parameters, update authorizations and chain parameters. emptyBlockState :: - forall pv m. - (SupportsPersistentState pv m) => - PersistentBirkParameters pv -> + forall store pv m. + (SupportsPersistentState store pv m) => + PersistentBirkParameters store pv -> CryptographicParameters -> UpdateKeysCollection (AuthorizationsVersionFor pv) -> ChainParameters pv -> - m (PersistentBlockState pv) + m (PersistentBlockState store pv) {-# WARNING emptyBlockState "should only be used for testing" #-} emptyBlockState bspBirkParameters cryptParams keysCollection chainParams = do modules <- refMake =<< Modules.emptyModules @@ -1059,12 +1105,12 @@ emptyBlockState bspBirkParameters cryptParams keysCollection chainParams = do liftIO $ newIORef $! bsp -- | Load 'BlockStatePointers' from a 'PersistentBlockState'. -loadPBS :: (SupportsPersistentState pv m) => PersistentBlockState pv -> m (BlockStatePointers pv) +loadPBS :: (SupportsPersistentState store pv m) => PersistentBlockState store pv -> m (BlockStatePointers store pv) loadPBS = loadBufferedRef <=< liftIO . readIORef {-# INLINE loadPBS #-} -- | Update the 'BlockStatePointers' stored in a 'PersistentBlockState'. -storePBS :: (SupportsPersistentAccount pv m) => PersistentBlockState pv -> BlockStatePointers pv -> m (PersistentBlockState pv) +storePBS :: (SupportsPersistentAccount store pv m) => PersistentBlockState store pv -> BlockStatePointers store pv -> m (PersistentBlockState store pv) storePBS pbs bsp = liftIO $ do pbsp <- makeBufferedRef bsp writeIORef pbs pbsp @@ -1079,9 +1125,9 @@ storePBS pbs bsp = liftIO $ do -- If @bid@ is not an active baker in @ab@, then the baker's equity capital (stake) is returned. -- It is assumed that all delegators to the baker @bid@ are delegator accounts in @accounts@. poolDelegatorCapital :: - forall pv m. - (IsProtocolVersion pv, PVSupportsDelegation pv, SupportsPersistentAccount pv m) => - BlockStatePointers pv -> + forall store pv m. + (IsProtocolVersion pv, PVSupportsDelegation pv, SupportsPersistentAccount store pv m) => + BlockStatePointers store pv -> BakerId -> m Amount poolDelegatorCapital bsp bid = do @@ -1092,8 +1138,8 @@ poolDelegatorCapital bsp bid = do -- | Get the total passively-delegated capital. passiveDelegationCapital :: - (IsProtocolVersion pv, PVSupportsDelegation pv, SupportsPersistentAccount pv m) => - BlockStatePointers pv -> + (IsProtocolVersion pv, PVSupportsDelegation pv, SupportsPersistentAccount store pv m) => + BlockStatePointers store pv -> m Amount passiveDelegationCapital bsp = do pab <- refLoad (bspBirkParameters bsp ^. birkActiveBakers) @@ -1102,7 +1148,7 @@ passiveDelegationCapital bsp = do -- | Get the total capital currently staked by bakers and delegators. -- Note, this is separate from the stake and capital distribution used for the current payday, as -- it reflects the current value of accounts. -totalCapital :: (IsProtocolVersion pv, PVSupportsDelegation pv, SupportsPersistentAccount pv m) => BlockStatePointers pv -> m Amount +totalCapital :: (IsProtocolVersion pv, PVSupportsDelegation pv, SupportsPersistentAccount store pv m) => BlockStatePointers store pv -> m Amount totalCapital bsp = do pab <- refLoad (bspBirkParameters bsp ^. birkActiveBakers) return $! pab ^. totalActiveCapitalV1 @@ -1110,13 +1156,13 @@ totalCapital bsp = do -- | Look up an account by index and run an operation on it. -- This returns 'Nothing' if the account is not present or the operation returns 'Nothing'. onAccount :: - (SupportsPersistentAccount pv m) => + (SupportsPersistentAccount store pv m) => -- | Account index to resolve AccountIndex -> -- | Block state - BlockStatePointers pv -> + BlockStatePointers store pv -> -- | Operation to apply to the account - (PersistentAccount (AccountVersionFor pv) -> m (Maybe a)) -> + (PersistentAccount store (AccountVersionFor pv) -> m (Maybe a)) -> m (Maybe a) onAccount ai bsp f = Accounts.indexedAccount ai (bspAccounts bsp) >>= \case @@ -1126,48 +1172,54 @@ onAccount ai bsp f = -- | Look up an account by index and run an operation on it. -- This returns 'Nothing' if the account is not present. onAccount' :: - (SupportsPersistentAccount pv m) => + (SupportsPersistentAccount store pv m) => -- | Account index to resolve AccountIndex -> -- | Block state - BlockStatePointers pv -> + BlockStatePointers store pv -> -- | Operation to apply to the account - (PersistentAccount (AccountVersionFor pv) -> m a) -> + (PersistentAccount store (AccountVersionFor pv) -> m a) -> m (Maybe a) onAccount' ai bsp f = Accounts.indexedAccount ai (bspAccounts bsp) >>= mapM f -doGetModule :: (SupportsPersistentState pv m) => PersistentBlockState pv -> ModuleRef -> m (Maybe (GSWasm.ModuleInterface Modules.PersistentInstrumentedModuleV)) +doGetModule :: + (SupportsPersistentState store pv m) => + PersistentBlockState store pv -> + ModuleRef -> + m (Maybe (GSWasm.ModuleInterface (Modules.PersistentInstrumentedModuleV store))) doGetModule s modRef = do bsp <- loadPBS s mods <- refLoad (bspModules bsp) Modules.getInterface modRef mods -doGetModuleArtifact :: (MonadBlobStore m, Wasm.IsWasmVersion v) => Modules.PersistentInstrumentedModuleV v -> m (GSWasm.InstrumentedModuleV v) +doGetModuleArtifact :: + (MonadBlobStore m, Wasm.IsWasmVersion v) => + Modules.PersistentInstrumentedModuleV (MBSStore m) v -> m (GSWasm.InstrumentedModuleV v) doGetModuleArtifact = Modules.loadInstrumentedModuleV -doGetModuleList :: (SupportsPersistentState pv m) => PersistentBlockState pv -> m [ModuleRef] +doGetModuleList :: (SupportsPersistentState store pv m) => PersistentBlockState store pv -> m [ModuleRef] doGetModuleList s = do bsp <- loadPBS s mods <- refLoad (bspModules bsp) Modules.moduleRefList mods -- | Get the size of the module table. -doGetModuleCount :: (SupportsPersistentState pv m) => PersistentBlockState pv -> m Word64 +doGetModuleCount :: (SupportsPersistentState store pv m) => PersistentBlockState store pv -> m Word64 doGetModuleCount s = do bsp <- loadPBS s Modules.moduleCount <$> refLoad (bspModules bsp) -doGetModuleSource :: (SupportsPersistentState pv m) => PersistentBlockState pv -> ModuleRef -> m (Maybe Wasm.WasmModule) +doGetModuleSource :: (SupportsPersistentState store pv m) => PersistentBlockState store pv -> ModuleRef -> m (Maybe Wasm.WasmModule) doGetModuleSource s modRef = do bsp <- loadPBS s mods <- refLoad (bspModules bsp) Modules.getSource modRef mods doPutNewModule :: - (Wasm.IsWasmVersion v, SupportsPersistentState pv m) => - PersistentBlockState pv -> + (Wasm.IsWasmVersion v, SupportsPersistentState store pv m) => + PersistentBlockState store pv -> (GSWasm.ModuleInterfaceV v, Wasm.WasmModuleV v) -> - m (Bool, PersistentBlockState pv) + m (Bool, PersistentBlockState store pv) doPutNewModule pbs (pmInterface, pmSource) = do bsp <- loadPBS pbs mods <- refLoad (bspModules bsp) @@ -1179,37 +1231,37 @@ doPutNewModule pbs (pmInterface, pmSource) = do (True,) <$> storePBS pbs (bsp{bspModules = modules}) doGetSeedState :: - (SupportsPersistentState pv m) => - PersistentBlockState pv -> + (SupportsPersistentState store pv m) => + PersistentBlockState store pv -> m (SeedState (SeedStateVersionFor pv)) doGetSeedState pbs = _birkSeedState . bspBirkParameters <$> loadPBS pbs doSetSeedState :: - (SupportsPersistentState pv m) => - PersistentBlockState pv -> + (SupportsPersistentState store pv m) => + PersistentBlockState store pv -> SeedState (SeedStateVersionFor pv) -> - m (PersistentBlockState pv) + m (PersistentBlockState store pv) doSetSeedState pbs ss = do bsp <- loadPBS pbs storePBS pbs bsp{bspBirkParameters = (bspBirkParameters bsp){_birkSeedState = ss}} doGetCurrentEpochFinalizationCommitteeParameters :: - ( SupportsPersistentState pv m, + ( SupportsPersistentState store pv m, IsSupported 'PTFinalizationCommitteeParameters (ChainParametersVersionFor pv) ~ 'True ) => - PersistentBlockState pv -> + PersistentBlockState store pv -> m FinalizationCommitteeParameters doGetCurrentEpochFinalizationCommitteeParameters pbs = do eb <- refLoad . _birkCurrentEpochBakers . bspBirkParameters =<< loadPBS pbs return $! eb ^. bakerFinalizationCommitteeParameters . supportedOParam -doGetCurrentEpochBakers :: (SupportsPersistentState pv m) => PersistentBlockState pv -> m FullBakers +doGetCurrentEpochBakers :: (SupportsPersistentState store pv m) => PersistentBlockState store pv -> m FullBakers doGetCurrentEpochBakers pbs = epochToFullBakers =<< refLoad . _birkCurrentEpochBakers . bspBirkParameters =<< loadPBS pbs -doGetCurrentEpochFullBakersEx :: (SupportsPersistentState pv m, PVSupportsDelegation pv) => PersistentBlockState pv -> m FullBakersEx +doGetCurrentEpochFullBakersEx :: (SupportsPersistentState store pv m, PVSupportsDelegation pv) => PersistentBlockState store pv -> m FullBakersEx doGetCurrentEpochFullBakersEx pbs = epochToFullBakersEx =<< refLoad . _birkCurrentEpochBakers . bspBirkParameters =<< loadPBS pbs -doGetCurrentCapitalDistribution :: forall pv m. (SupportsPersistentState pv m, PVSupportsDelegation pv) => PersistentBlockState pv -> m CapitalDistribution +doGetCurrentCapitalDistribution :: forall store pv m. (SupportsPersistentState store pv m, PVSupportsDelegation pv) => PersistentBlockState store pv -> m CapitalDistribution doGetCurrentCapitalDistribution pbs = do bsp <- loadPBS pbs let hpr = case bspRewardDetails bsp of BlockRewardDetailsV1 hp -> hp @@ -1217,16 +1269,16 @@ doGetCurrentCapitalDistribution pbs = do refLoad $ currentCapital poolRewards doGetNextEpochFinalizationCommitteeParameters :: - ( SupportsPersistentState pv m, + ( SupportsPersistentState store pv m, IsSupported 'PTFinalizationCommitteeParameters (ChainParametersVersionFor pv) ~ 'True ) => - PersistentBlockState pv -> + PersistentBlockState store pv -> m FinalizationCommitteeParameters doGetNextEpochFinalizationCommitteeParameters pbs = do eb <- refLoad . _birkNextEpochBakers . bspBirkParameters =<< loadPBS pbs return $! eb ^. bakerFinalizationCommitteeParameters . supportedOParam -doGetNextEpochBakers :: (SupportsPersistentState pv m) => PersistentBlockState pv -> m FullBakers +doGetNextEpochBakers :: (SupportsPersistentState store pv m) => PersistentBlockState store pv -> m FullBakers doGetNextEpochBakers pbs = do bsp <- loadPBS pbs epochToFullBakers =<< refLoad (bspBirkParameters bsp ^. birkNextEpochBakers) @@ -1234,9 +1286,9 @@ doGetNextEpochBakers pbs = do doGetSlotBakersP1 :: ( AccountVersionFor pv ~ 'AccountV0, SeedStateVersionFor pv ~ 'SeedStateVersion0, - SupportsPersistentState pv m + SupportsPersistentState store pv m ) => - PersistentBlockState pv -> + PersistentBlockState store pv -> Slot -> m FullBakers doGetSlotBakersP1 pbs slot = do @@ -1266,19 +1318,19 @@ doGetSlotBakersP1 pbs slot = do bakerTotalStake = sum (_bakerStake <$> futureBakers) } -doGetBakerAccount :: (SupportsPersistentState pv m) => PersistentBlockState pv -> BakerId -> m (Maybe (PersistentAccount (AccountVersionFor pv))) +doGetBakerAccount :: (SupportsPersistentState store pv m) => PersistentBlockState store pv -> BakerId -> m (Maybe (PersistentAccount store (AccountVersionFor pv))) doGetBakerAccount pbs (BakerId ai) = do bsp <- loadPBS pbs Accounts.indexedAccount ai (bspAccounts bsp) -doTransitionEpochBakers :: forall m pv. (SupportsPersistentState pv m, AccountVersionFor pv ~ 'AccountV0) => PersistentBlockState pv -> Epoch -> m (PersistentBlockState pv) +doTransitionEpochBakers :: forall m store pv. (SupportsPersistentState store pv m, AccountVersionFor pv ~ 'AccountV0) => PersistentBlockState store pv -> Epoch -> m (PersistentBlockState store pv) doTransitionEpochBakers pbs newEpoch = do bsp <- loadPBS pbs let oldBPs = bspBirkParameters bsp curActiveBIDs <- Trie.keysAsc . _activeBakers =<< refLoad (_birkActiveBakers oldBPs) -- Retrieve/update the baker info, accumulating the baker info to the list if it is still a -- baker after updating to account for any elapsed pending update. - let accumBakers :: (BlockStatePointers pv, [(PersistentBakerInfoRef 'AccountV0, Amount)]) -> BakerId -> m (BlockStatePointers pv, [(PersistentBakerInfoRef 'AccountV0, Amount)]) + let accumBakers :: (BlockStatePointers store pv, [(PersistentBakerInfoRef store 'AccountV0, Amount)]) -> BakerId -> m (BlockStatePointers store pv, [(PersistentBakerInfoRef store 'AccountV0, Amount)]) accumBakers (bs0, bkrs0) bkr@(BakerId aid) = onAccount aid bsp accountBakerAndInfoRef >>= \case Just (acctBkr, binfoRef) -> @@ -1359,13 +1411,13 @@ doTransitionEpochBakers pbs newEpoch = do return $ if (h1 :: H.Hash) == h2 then b else a doGetActiveBakersAndDelegators :: - forall pv m. + forall store pv m. ( IsProtocolVersion pv, - SupportsPersistentState pv m, + SupportsPersistentState store pv m, PVSupportsDelegation pv, - BakerInfoRef m ~ PersistentBakerInfoRef (AccountVersionFor pv) + BakerInfoRef m ~ PersistentBakerInfoRef store (AccountVersionFor pv) ) => - PersistentBlockState pv -> + PersistentBlockState store pv -> m ([ActiveBakerInfo m], [ActiveDelegatorInfo]) doGetActiveBakersAndDelegators pbs = do bsp <- loadPBS pbs @@ -1401,7 +1453,7 @@ doGetActiveBakersAndDelegators pbs = do BaseAccounts._accountBakerInfo $ theBaker } - mkActiveDelegatorInfo :: BlockStatePointers pv -> DelegatorId -> m ActiveDelegatorInfo + mkActiveDelegatorInfo :: BlockStatePointers store pv -> DelegatorId -> m ActiveDelegatorInfo mkActiveDelegatorInfo bsp activeDelegatorId@(DelegatorId acct) = onAccount acct bsp accountDelegator >>= \case Nothing -> error "Invariant violation: active delegator is not a delegator account" @@ -1419,12 +1471,12 @@ doGetActiveBakersAndDelegators pbs = do -- The baker id is used to identify the pool and Nothing is used for the passive delegators. -- Returns Nothing if it fails to identify the baker pool. Should always return a value for the passive delegators. doGetActiveDelegators :: - forall pv m. + forall store pv m. ( IsProtocolVersion pv, - SupportsPersistentState pv m, + SupportsPersistentState store pv m, PVSupportsDelegation pv ) => - PersistentBlockState pv -> + PersistentBlockState store pv -> Maybe BakerId -> m (Maybe [(AccountAddress, ActiveDelegatorInfo)]) doGetActiveDelegators pbs mPoolId = do @@ -1443,7 +1495,7 @@ doGetActiveDelegators pbs mPoolId = do lps <- Trie.keys dlgs >>= mapM (mkActiveDelegatorInfo bsp) return (Just lps) where - mkActiveDelegatorInfo :: BlockStatePointers pv -> DelegatorId -> m (AccountAddress, ActiveDelegatorInfo) + mkActiveDelegatorInfo :: BlockStatePointers store pv -> DelegatorId -> m (AccountAddress, ActiveDelegatorInfo) mkActiveDelegatorInfo bsp activeDelegatorId@(DelegatorId acct) = do let myFromJust = fromMaybe (error "Invariant violation: active baker is not a baker account") theAcct <- myFromJust <$> Accounts.indexedAccount acct (bspAccounts bsp) @@ -1464,11 +1516,11 @@ doGetActiveDelegators pbs mPoolId = do -- The baker id is used to identify the pool and Nothing is used for the passive delegators. -- Returns Nothing if it fails to identify the baker pool. Should always return a value for the passive delegators. doGetCurrentDelegators :: - forall pv m. - ( SupportsPersistentState pv m, + forall store pv m. + ( SupportsPersistentState store pv m, PVSupportsDelegation pv ) => - PersistentBlockState pv -> + PersistentBlockState store pv -> Maybe BakerId -> m (Maybe [(AccountAddress, DelegatorCapital)]) doGetCurrentDelegators pbs mPoolId = do @@ -1494,11 +1546,11 @@ doGetCurrentDelegators pbs mPoolId = do return (Just dlgs) doAddBaker :: - (SupportsPersistentState pv m, AccountVersionFor pv ~ 'AccountV0, ChainParametersVersionFor pv ~ 'ChainParametersV0) => - PersistentBlockState pv -> + (SupportsPersistentState store pv m, AccountVersionFor pv ~ 'AccountV0, ChainParametersVersionFor pv ~ 'ChainParametersV0) => + PersistentBlockState store pv -> AccountIndex -> BakerAdd -> - m (BakerAddResult, PersistentBlockState pv) + m (BakerAddResult, PersistentBlockState store pv) doAddBaker pbs ai ba@BakerAdd{..} = do bsp <- loadPBS pbs Accounts.indexedAccount ai (bspAccounts bsp) >>= \case @@ -1546,11 +1598,11 @@ doAddBaker pbs ai ba@BakerAdd{..} = do -- and does not update the active baker index, which must be handled separately. -- The account __must__ be an active delegator. redelegatePassive :: - forall pv m. - (SupportsPersistentAccount pv m, PVSupportsDelegation pv) => - Accounts.Accounts pv -> + forall store pv m. + (SupportsPersistentAccount store pv m, PVSupportsDelegation pv) => + Accounts.Accounts store pv -> DelegatorId -> - m (Accounts.Accounts pv) + m (Accounts.Accounts store pv) redelegatePassive accounts (DelegatorId accId) = Accounts.updateAccountsAtIndex' (setAccountDelegationTarget Transactions.DelegatePassive) @@ -1572,11 +1624,11 @@ redelegatePassive accounts (DelegatorId accId) = -- 'VCFFinalizationRewardCommissionNotInRange'. -- 5. If the aggregation key is a duplicate, throw 'VCFDuplicateAggregationKey'. addValidatorChecks :: - forall pv m. - ( SupportsPersistentState pv m, + forall store pv m. + ( SupportsPersistentState store pv m, PoolParametersVersionFor (ChainParametersVersionFor pv) ~ 'PoolParametersVersion1 ) => - BlockStatePointers pv -> + BlockStatePointers store pv -> ValidatorAdd -> MTL.ExceptT ValidatorConfigureFailure m () addValidatorChecks bsp ValidatorAdd{..} = do @@ -1645,17 +1697,17 @@ addValidatorChecks bsp ValidatorAdd{..} = do -- -- 7. Return the updated block state. newAddValidator :: - forall pv m. - ( SupportsPersistentState pv m, + forall store pv m. + ( SupportsPersistentState store pv m, PVSupportsDelegation pv, IsSupported 'PTTimeParameters (ChainParametersVersionFor pv) ~ 'True, PoolParametersVersionFor (ChainParametersVersionFor pv) ~ 'PoolParametersVersion1, CooldownParametersVersionFor (ChainParametersVersionFor pv) ~ 'CooldownParametersVersion1 ) => - PersistentBlockState (MPV m) -> + PersistentBlockState store (MPV m) -> AccountIndex -> ValidatorAdd -> - MTL.ExceptT ValidatorConfigureFailure m (PersistentBlockState (MPV m)) + MTL.ExceptT ValidatorConfigureFailure m (PersistentBlockState store (MPV m)) newAddValidator pbs ai va@ValidatorAdd{..} = do bsp <- loadPBS pbs addValidatorChecks bsp va @@ -1733,11 +1785,11 @@ newAddValidator pbs ai va@ValidatorAdd{..} = do -- * If the capital is non-zero, and less than the current minimum equity capital, throw -- @BCStakeUnderThreshold@. updateValidatorChecks :: - forall pv m. - ( SupportsPersistentState pv m, + forall store pv m. + ( SupportsPersistentState store pv m, PoolParametersVersionFor (ChainParametersVersionFor pv) ~ 'PoolParametersVersion1 ) => - BlockStatePointers pv -> + BlockStatePointers store pv -> -- | The current baker on the account being updated AccountBaker (AccountVersionFor pv) -> ValidatorUpdate -> @@ -1877,19 +1929,19 @@ updateValidatorChecks bsp baker ValidatorUpdate{..} = do -- 10. Return @events@ with the updated block state. newUpdateValidator :: - forall pv m. - ( SupportsPersistentState pv m, + forall store pv m. + ( SupportsPersistentState store pv m, PVSupportsDelegation pv, IsSupported 'PTTimeParameters (ChainParametersVersionFor pv) ~ 'True, PoolParametersVersionFor (ChainParametersVersionFor pv) ~ 'PoolParametersVersion1, CooldownParametersVersionFor (ChainParametersVersionFor pv) ~ 'CooldownParametersVersion1 ) => - PersistentBlockState (MPV m) -> + PersistentBlockState store (MPV m) -> -- | Current block timestamp Timestamp -> AccountIndex -> ValidatorUpdate -> - MTL.ExceptT ValidatorConfigureFailure m ([BakerConfigureUpdateChange], PersistentBlockState (MPV m)) + MTL.ExceptT ValidatorConfigureFailure m ([BakerConfigureUpdateChange], PersistentBlockState store (MPV m)) newUpdateValidator pbs curTimestamp ai vu@ValidatorUpdate{..} = do bsp <- loadPBS pbs -- Cannot fail: The precondition guaranties that the account exists @@ -2093,8 +2145,8 @@ newUpdateValidator pbs curTimestamp ai vu@ValidatorUpdate{..} = do return bsp{bspBirkParameters = bspBirkParameters bsp & birkActiveBakers .~ newPABref} addToPrePreCooldowns :: (MonadBlobStore m', PVSupportsFlexibleCooldown pv) => - BlockStatePointers pv -> - m' (BlockStatePointers pv) + BlockStatePointers (MBSStore m') pv -> + m' (BlockStatePointers (MBSStore m') pv) addToPrePreCooldowns bsp = do -- Add the account to the pre-pre-cooldowns list. newAccountsInCooldown <- @@ -2104,11 +2156,11 @@ newUpdateValidator pbs curTimestamp ai vu@ValidatorUpdate{..} = do return bsp{bspAccountsInCooldown = newAccountsInCooldown} doConstrainBakerCommission :: - (SupportsPersistentState pv m, PVSupportsDelegation pv) => - PersistentBlockState pv -> + (SupportsPersistentState store pv m, PVSupportsDelegation pv) => + PersistentBlockState store pv -> AccountIndex -> CommissionRanges -> - m (PersistentBlockState pv) + m (PersistentBlockState store pv) doConstrainBakerCommission pbs ai ranges = do bsp <- loadPBS pbs onAccount ai bsp accountBaker >>= \case @@ -2147,10 +2199,10 @@ addDelegatorChecks :: ( IsProtocolVersion pv, PVSupportsDelegation pv, MTL.MonadError DelegatorConfigureFailure m, - SupportsPersistentAccount pv m, + SupportsPersistentAccount store pv m, PoolParametersVersionFor (ChainParametersVersionFor pv) ~ 'PoolParametersVersion1 ) => - BlockStatePointers pv -> + BlockStatePointers store pv -> DelegatorAdd -> m () addDelegatorChecks _ DelegatorAdd{daDelegationTarget = Transactions.DelegatePassive} = return () @@ -2204,17 +2256,17 @@ addDelegatorChecks bsp DelegatorAdd{daDelegationTarget = Transactions.DelegateTo -- -- 7. Return the updated state. newAddDelegator :: - forall pv m. - ( SupportsPersistentState pv m, + forall store pv m. + ( SupportsPersistentState store pv m, PVSupportsDelegation pv, IsSupported 'PTTimeParameters (ChainParametersVersionFor pv) ~ 'True, PoolParametersVersionFor (ChainParametersVersionFor pv) ~ 'PoolParametersVersion1, CooldownParametersVersionFor (ChainParametersVersionFor pv) ~ 'CooldownParametersVersion1 ) => - PersistentBlockState (MPV m) -> + PersistentBlockState store (MPV m) -> AccountIndex -> DelegatorAdd -> - MTL.ExceptT DelegatorConfigureFailure m (PersistentBlockState (MPV m)) + MTL.ExceptT DelegatorConfigureFailure m (PersistentBlockState store (MPV m)) newAddDelegator pbs ai da@DelegatorAdd{..} = do bsp <- loadPBS pbs addDelegatorChecks bsp da @@ -2284,14 +2336,14 @@ newAddDelegator pbs ai da@DelegatorAdd{..} = do -- * If the amount delegated to the delegation target would exceed the capital bound, -- throw 'DCFPoolOverDelegated'. updateDelegatorChecks :: - forall pv m. + forall store pv m. ( IsProtocolVersion pv, PVSupportsDelegation pv, MTL.MonadError DelegatorConfigureFailure m, - SupportsPersistentAccount pv m, + SupportsPersistentAccount store pv m, PoolParametersVersionFor (ChainParametersVersionFor pv) ~ 'PoolParametersVersion1 ) => - BlockStatePointers pv -> + BlockStatePointers store pv -> -- | The current delegation status of the account. BaseAccounts.AccountDelegation (AccountVersionFor pv) -> DelegatorUpdate -> @@ -2432,19 +2484,19 @@ updateDelegatorChecks bsp oldDelegator DelegatorUpdate{..} = do -- -- 6. Return @events@ with the updated state. newUpdateDelegator :: - forall pv m. - ( SupportsPersistentState pv m, + forall store pv m. + ( SupportsPersistentState store pv m, PVSupportsDelegation pv, IsSupported 'PTTimeParameters (ChainParametersVersionFor pv) ~ 'True, PoolParametersVersionFor (ChainParametersVersionFor pv) ~ 'PoolParametersVersion1, CooldownParametersVersionFor (ChainParametersVersionFor pv) ~ 'CooldownParametersVersion1 ) => - PersistentBlockState (MPV m) -> + PersistentBlockState store (MPV m) -> -- | Current block timestamp Timestamp -> AccountIndex -> DelegatorUpdate -> - MTL.ExceptT DelegatorConfigureFailure m ([DelegationConfigureUpdateChange], PersistentBlockState (MPV m)) + MTL.ExceptT DelegatorConfigureFailure m ([DelegationConfigureUpdateChange], PersistentBlockState store (MPV m)) newUpdateDelegator pbs blockTimestamp ai du@DelegatorUpdate{..} = do bsp <- loadPBS pbs -- Cannot fail: The precondition guarantees that the account exists. @@ -2566,8 +2618,8 @@ newUpdateDelegator pbs blockTimestamp ai du@DelegatorUpdate{..} = do return bsp{bspBirkParameters = bspBirkParameters bsp & birkActiveBakers .~ newPABRef} addToPrePreCooldowns :: (MonadBlobStore m', PVSupportsFlexibleCooldown pv) => - BlockStatePointers pv -> - m' (BlockStatePointers pv) + BlockStatePointers (MBSStore m') pv -> + m' (BlockStatePointers (MBSStore m') pv) addToPrePreCooldowns bsp = do -- Add the account to the pre-pre-cooldowns list. newAccountsInCooldown <- @@ -2614,8 +2666,8 @@ applyCooldownRemovalsGlobally :: (MonadBlobStore m, PVSupportsFlexibleCooldown pv) => AccountIndex -> CooldownRemovals -> - AccountsInCooldownForPV pv -> - m (AccountsInCooldownForPV pv) + AccountsInCooldownForPV (MBSStore m) pv -> + m (AccountsInCooldownForPV (MBSStore m) pv) applyCooldownRemovalsGlobally ai CooldownRemovals{..} = doIf crPrePreCooldown ((accountsInCooldown . prePreCooldown) (removeAccountFromAccountList ai)) >=> doIf crPreCooldown ((accountsInCooldown . preCooldown) (removeAccountFromAccountList ai)) @@ -2627,11 +2679,11 @@ applyCooldownRemovalsGlobally ai CooldownRemovals{..} = doIf False _ = return doUpdateBakerKeys :: - (SupportsPersistentState pv m, AccountVersionFor pv ~ 'AccountV0) => - PersistentBlockState pv -> + (SupportsPersistentState store pv m, AccountVersionFor pv ~ 'AccountV0) => + PersistentBlockState store pv -> AccountIndex -> BakerKeyUpdate -> - m (BakerKeyUpdateResult, PersistentBlockState pv) + m (BakerKeyUpdateResult, PersistentBlockState store pv) doUpdateBakerKeys pbs ai bku@BakerKeyUpdate{..} = do bsp <- loadPBS pbs onAccount ai bsp accountBaker >>= \case @@ -2670,11 +2722,11 @@ doUpdateBakerKeys pbs ai bku@BakerKeyUpdate{..} = do _ -> return (BKUInvalidBaker, pbs) doUpdateBakerStake :: - (SupportsPersistentState pv m, AccountVersionFor pv ~ 'AccountV0, ChainParametersVersionFor pv ~ 'ChainParametersV0) => - PersistentBlockState pv -> + (SupportsPersistentState store pv m, AccountVersionFor pv ~ 'AccountV0, ChainParametersVersionFor pv ~ 'ChainParametersV0) => + PersistentBlockState store pv -> AccountIndex -> Amount -> - m (BakerStakeUpdateResult, PersistentBlockState pv) + m (BakerStakeUpdateResult, PersistentBlockState store pv) doUpdateBakerStake pbs ai newStake = do bsp <- loadPBS pbs @@ -2710,11 +2762,11 @@ doUpdateBakerStake pbs ai newStake = do _ -> return (BSUInvalidBaker, pbs) doUpdateBakerRestakeEarnings :: - (SupportsPersistentState pv m) => - PersistentBlockState pv -> + (SupportsPersistentState store pv m) => + PersistentBlockState store pv -> AccountIndex -> Bool -> - m (BakerRestakeEarningsUpdateResult, PersistentBlockState pv) + m (BakerRestakeEarningsUpdateResult, PersistentBlockState store pv) doUpdateBakerRestakeEarnings pbs ai newRestakeEarnings = do bsp <- loadPBS pbs onAccount' ai bsp accountStakeDetails >>= \case @@ -2728,10 +2780,10 @@ doUpdateBakerRestakeEarnings pbs ai newRestakeEarnings = do _ -> return (BREUInvalidBaker, pbs) doRemoveBaker :: - (SupportsPersistentState pv m, AccountVersionFor pv ~ 'AccountV0, ChainParametersVersionFor pv ~ 'ChainParametersV0) => - PersistentBlockState pv -> + (SupportsPersistentState store pv m, AccountVersionFor pv ~ 'AccountV0, ChainParametersVersionFor pv ~ 'ChainParametersV0) => + PersistentBlockState store pv -> AccountIndex -> - m (BakerRemoveResult, PersistentBlockState pv) + m (BakerRemoveResult, PersistentBlockState store pv) doRemoveBaker pbs ai = do bsp <- loadPBS pbs onAccount' ai bsp accountStakeDetails >>= \case @@ -2760,7 +2812,7 @@ doRemoveBaker pbs ai = do -- The account is not valid or has no baker _ -> return (BRInvalidBaker, pbs) -doRewardAccount :: forall pv m. (SupportsPersistentState pv m) => PersistentBlockState pv -> AccountIndex -> Amount -> m (Maybe AccountAddress, PersistentBlockState pv) +doRewardAccount :: forall store pv m. (SupportsPersistentState store pv m) => PersistentBlockState store pv -> AccountIndex -> Amount -> m (Maybe AccountAddress, PersistentBlockState store pv) doRewardAccount pbs ai reward = do bsp <- loadPBS pbs (mRes, newAccounts) <- Accounts.updateAccountsAtIndex updAcc ai (bspAccounts bsp) @@ -2799,9 +2851,9 @@ doRewardAccount pbs ai reward = do updateDelegationPoolCapital :: (AVSupportsDelegation av, IsAccountVersion av) => - PersistentActiveBakers av -> + PersistentActiveBakers (MBSStore m) av -> Transactions.DelegationTarget -> - m (PersistentActiveBakers av) + m (PersistentActiveBakers (MBSStore m) av) updateDelegationPoolCapital activeBkrs Transactions.DelegatePassive = do let tot = adDelegatorTotalCapital $ activeBkrs ^. passiveDelegators return $! @@ -2817,7 +2869,7 @@ doRewardAccount pbs ai reward = do (_, newActiveBkrsMap) <- Trie.adjust adj bid activeBkrsMap return $! activeBkrs & activeBakers .~ newActiveBkrsMap -doGetBakerPoolRewardDetails :: (PVSupportsDelegation pv, SupportsPersistentState pv m) => PersistentBlockState pv -> m (Map.Map BakerId (BakerPoolRewardDetails (AccountVersionFor pv))) +doGetBakerPoolRewardDetails :: (PVSupportsDelegation pv, SupportsPersistentState store pv m) => PersistentBlockState store pv -> m (Map.Map BakerId (BakerPoolRewardDetails (AccountVersionFor pv))) doGetBakerPoolRewardDetails pbs = do bsp <- loadPBS pbs let hpr = case bspRewardDetails bsp of BlockRewardDetailsV1 hp -> hp @@ -2829,7 +2881,7 @@ doGetBakerPoolRewardDetails pbs = do -- distribution is updated. return $! Map.fromList (zip bakerIdList rewardsList) -doGetRewardStatus :: forall pv m. (SupportsPersistentState pv m) => PersistentBlockState pv -> m (RewardStatus' Epoch) +doGetRewardStatus :: forall store pv m. (SupportsPersistentState store pv m) => PersistentBlockState store pv -> m (RewardStatus' Epoch) doGetRewardStatus pbs = do bsp <- loadPBS pbs let bankStatus = _unhashed $ bspBank bsp @@ -2872,7 +2924,7 @@ doGetRewardStatus pbs = do SP9 -> rewardsV1 SP10 -> rewardsV1 -doRewardFoundationAccount :: (SupportsPersistentState pv m) => PersistentBlockState pv -> Amount -> m (PersistentBlockState pv) +doRewardFoundationAccount :: (SupportsPersistentState store pv m) => PersistentBlockState store pv -> Amount -> m (PersistentBlockState store pv) doRewardFoundationAccount pbs reward = do bsp <- loadPBS pbs let updAcc = addAccountAmount reward @@ -2880,7 +2932,7 @@ doRewardFoundationAccount pbs reward = do newAccounts <- Accounts.updateAccountsAtIndex' updAcc foundationAccount (bspAccounts bsp) storePBS pbs (bsp{bspAccounts = newAccounts}) -doGetFoundationAccount :: (SupportsPersistentState pv m) => PersistentBlockState pv -> m (PersistentAccount (AccountVersionFor pv)) +doGetFoundationAccount :: (SupportsPersistentState store pv m) => PersistentBlockState store pv -> m (PersistentAccount store (AccountVersionFor pv)) doGetFoundationAccount pbs = do bsp <- loadPBS pbs foundationAccount <- (^. cpFoundationAccount) <$> lookupCurrentParameters (bspUpdates bsp) @@ -2889,7 +2941,7 @@ doGetFoundationAccount pbs = do Nothing -> error "bsoGetFoundationAccount: invalid foundation account" Just acc -> return acc -doMint :: (SupportsPersistentState pv m) => PersistentBlockState pv -> MintAmounts -> m (PersistentBlockState pv) +doMint :: (SupportsPersistentState store pv m) => PersistentBlockState store pv -> MintAmounts -> m (PersistentBlockState store pv) doMint pbs mint = do bsp <- loadPBS pbs let newBank = @@ -2903,7 +2955,7 @@ doMint pbs mint = do newAccounts <- Accounts.updateAccountsAtIndex' updAcc foundationAccount (bspAccounts bsp) storePBS pbs (bsp{bspBank = newBank, bspAccounts = newAccounts}) -doSafeMintToAccount :: (SupportsPersistentState pv m) => PersistentBlockState pv -> AccountIndex -> Amount -> m (Either Amount (PersistentBlockState pv)) +doSafeMintToAccount :: (SupportsPersistentState store pv m) => PersistentBlockState store pv -> AccountIndex -> Amount -> m (Either Amount (PersistentBlockState store pv)) doSafeMintToAccount pbs acctIdx mintAmt = do bsp <- loadPBS pbs let currentSupply = bspBank bsp ^. unhashed . Rewards.totalGTU @@ -2916,51 +2968,51 @@ doSafeMintToAccount pbs acctIdx mintAmt = do Right <$> storePBS pbs (bsp{bspBank = newBank, bspAccounts = newAccounts}) else return $ Left maxMintAmount -doGetAccount :: (SupportsPersistentState pv m) => PersistentBlockState pv -> AccountAddress -> m (Maybe (AccountIndex, PersistentAccount (AccountVersionFor pv))) +doGetAccount :: (SupportsPersistentState store pv m) => PersistentBlockState store pv -> AccountAddress -> m (Maybe (AccountIndex, PersistentAccount store (AccountVersionFor pv))) doGetAccount pbs addr = do bsp <- loadPBS pbs Accounts.getAccountWithIndex addr (bspAccounts bsp) -doGetAccountExists :: (SupportsPersistentState pv m) => PersistentBlockState pv -> AccountAddress -> m Bool +doGetAccountExists :: (SupportsPersistentState store pv m) => PersistentBlockState store pv -> AccountAddress -> m Bool doGetAccountExists pbs aaddr = do bsp <- loadPBS pbs Accounts.exists aaddr (bspAccounts bsp) -doGetActiveBakers :: (SupportsPersistentState pv m) => PersistentBlockState pv -> m [BakerId] +doGetActiveBakers :: (SupportsPersistentState store pv m) => PersistentBlockState store pv -> m [BakerId] doGetActiveBakers pbs = do bsp <- loadPBS pbs ab <- refLoad $ bspBirkParameters bsp ^. birkActiveBakers Trie.keysAsc (ab ^. activeBakers) -doGetAccountByCredId :: (SupportsPersistentState pv m) => PersistentBlockState pv -> ID.RawCredentialRegistrationID -> m (Maybe (AccountIndex, PersistentAccount (AccountVersionFor pv))) +doGetAccountByCredId :: (SupportsPersistentState store pv m) => PersistentBlockState store pv -> ID.RawCredentialRegistrationID -> m (Maybe (AccountIndex, PersistentAccount store (AccountVersionFor pv))) doGetAccountByCredId pbs cid = do bsp <- loadPBS pbs Accounts.getAccountByCredId cid (bspAccounts bsp) -doGetAccountIndex :: (SupportsPersistentState pv m) => PersistentBlockState pv -> AccountAddress -> m (Maybe AccountIndex) +doGetAccountIndex :: (SupportsPersistentState store pv m) => PersistentBlockState store pv -> AccountAddress -> m (Maybe AccountIndex) doGetAccountIndex pbs addr = do bsp <- loadPBS pbs Accounts.getAccountIndex addr (bspAccounts bsp) -doGetAccountByIndex :: (SupportsPersistentState pv m) => PersistentBlockState pv -> AccountIndex -> m (Maybe (PersistentAccount (AccountVersionFor pv))) +doGetAccountByIndex :: (SupportsPersistentState store pv m) => PersistentBlockState store pv -> AccountIndex -> m (Maybe (PersistentAccount store (AccountVersionFor pv))) doGetAccountByIndex pbs aid = do bsp <- loadPBS pbs Accounts.indexedAccount aid (bspAccounts bsp) -doGetIndexedAccountByIndex :: (SupportsPersistentState pv m) => PersistentBlockState pv -> AccountIndex -> m (Maybe (AccountIndex, PersistentAccount (AccountVersionFor pv))) +doGetIndexedAccountByIndex :: (SupportsPersistentState store pv m) => PersistentBlockState store pv -> AccountIndex -> m (Maybe (AccountIndex, PersistentAccount store (AccountVersionFor pv))) doGetIndexedAccountByIndex pbs idx = fmap (idx,) <$> doGetAccountByIndex pbs idx -doAccountList :: (SupportsPersistentState pv m) => PersistentBlockState pv -> m [AccountAddress] +doAccountList :: (SupportsPersistentState store pv m) => PersistentBlockState store pv -> m [AccountAddress] doAccountList pbs = do bsp <- loadPBS pbs Accounts.accountAddresses (bspAccounts bsp) -doRegIdExists :: (SupportsPersistentState pv m) => PersistentBlockState pv -> ID.CredentialRegistrationID -> m Bool +doRegIdExists :: (SupportsPersistentState store pv m) => PersistentBlockState store pv -> ID.CredentialRegistrationID -> m Bool doRegIdExists pbs regid = do bsp <- loadPBS pbs isJust <$> Accounts.regIdExists regid (bspAccounts bsp) -doCreateAccount :: (SupportsPersistentState pv m) => PersistentBlockState pv -> ID.GlobalContext -> AccountAddress -> ID.AccountCredential -> m (Maybe (PersistentAccount (AccountVersionFor pv)), PersistentBlockState pv) +doCreateAccount :: (SupportsPersistentState store pv m) => PersistentBlockState store pv -> ID.GlobalContext -> AccountAddress -> ID.AccountCredential -> m (Maybe (PersistentAccount store (AccountVersionFor pv)), PersistentBlockState store pv) doCreateAccount pbs cryptoParams acctAddr credential = do acct <- newAccount cryptoParams acctAddr credential bsp <- loadPBS pbs @@ -2975,7 +3027,7 @@ doCreateAccount pbs cryptoParams acctAddr credential = do -- the account was not created return (Nothing, pbs) -doModifyAccount :: forall m pv. (SupportsPersistentState pv m) => PersistentBlockState pv -> AccountUpdate -> m (PersistentBlockState pv) +doModifyAccount :: forall store m pv. (SupportsPersistentState store pv m) => PersistentBlockState store pv -> AccountUpdate -> m (PersistentBlockState store pv) doModifyAccount pbs aUpd@AccountUpdate{..} = do bsp <- loadPBS pbs -- Do the update to the account. The first component of the return value is a @Just@ when @@ -2984,8 +3036,8 @@ doModifyAccount pbs aUpd@AccountUpdate{..} = do -- (or @Nothing@ if there was none), and the new first release timestamp (or @Nothing@ if -- there is none). These are used to update the release schedule index as necessary. let doUpd :: - PersistentAccount (AccountVersionFor pv) -> - m (Maybe (RSAccountRef pv, Maybe Timestamp, Maybe Timestamp), PersistentAccount (AccountVersionFor pv)) + PersistentAccount store (AccountVersionFor pv) -> + m (Maybe (RSAccountRef pv, Maybe Timestamp, Maybe Timestamp), PersistentAccount store (AccountVersionFor pv)) doUpd acc = do acc' <- updateAccount aUpd acc releaseChange <- forM _auReleaseSchedule $ \_ -> do @@ -3012,7 +3064,7 @@ doModifyAccount pbs aUpd@AccountUpdate{..} = do _ -> return $ bspReleaseSchedule bsp storePBS pbs (bsp{bspAccounts = accts1, bspReleaseSchedule = newRS}) -doSetAccountCredentialKeys :: (SupportsPersistentState pv m) => PersistentBlockState pv -> AccountIndex -> ID.CredentialIndex -> ID.CredentialPublicKeys -> m (PersistentBlockState pv) +doSetAccountCredentialKeys :: (SupportsPersistentState store pv m) => PersistentBlockState store pv -> AccountIndex -> ID.CredentialIndex -> ID.CredentialPublicKeys -> m (PersistentBlockState store pv) doSetAccountCredentialKeys pbs accIndex credIx credKeys = do bsp <- loadPBS pbs accts1 <- Accounts.updateAccountsAtIndex' upd accIndex (bspAccounts bsp) @@ -3021,8 +3073,8 @@ doSetAccountCredentialKeys pbs accIndex credIx credKeys = do upd = updateAccountCredentialKeys credIx credKeys doUpdateAccountCredentials :: - (SupportsPersistentState pv m) => - PersistentBlockState pv -> + (SupportsPersistentState store pv m) => + PersistentBlockState store pv -> -- | Address of the account to update. AccountIndex -> -- | List of credential indices to remove. @@ -3031,7 +3083,7 @@ doUpdateAccountCredentials :: Map.Map ID.CredentialIndex ID.AccountCredential -> -- | New account threshold ID.AccountThreshold -> - m (PersistentBlockState pv) + m (PersistentBlockState store pv) doUpdateAccountCredentials pbs accIndex remove add thrsh = do bsp <- loadPBS pbs (res, accts1) <- Accounts.updateAccountsAtIndex upd accIndex (bspAccounts bsp) @@ -3045,26 +3097,26 @@ doUpdateAccountCredentials pbs accIndex remove add thrsh = do upd oldAccount = ((),) <$> updateAccountCredentials remove add thrsh oldAccount doGetInstance :: - (SupportsPersistentState pv m) => - PersistentBlockState pv -> + (SupportsPersistentState store pv m) => + PersistentBlockState store pv -> ContractAddress -> - m (Maybe (InstanceInfoType Modules.PersistentInstrumentedModuleV Instances.InstanceStateV)) + m (Maybe (InstanceInfoType (Modules.PersistentInstrumentedModuleV store) (Instances.InstanceStateV store))) doGetInstance pbs caddr = do bsp <- loadPBS pbs minst <- Instances.lookupContractInstance caddr (bspInstances bsp) forM minst Instances.mkInstanceInfo -doContractInstanceList :: (SupportsPersistentState pv m) => PersistentBlockState pv -> m [ContractAddress] +doContractInstanceList :: (SupportsPersistentState store pv m) => PersistentBlockState store pv -> m [ContractAddress] doContractInstanceList pbs = do bsp <- loadPBS pbs Instances.allInstances (bspInstances bsp) doPutNewInstance :: - forall m pv v. - (SupportsPersistentState pv m, Wasm.IsWasmVersion v) => - PersistentBlockState pv -> - NewInstanceData (Modules.PersistentInstrumentedModuleV v) v -> - m (ContractAddress, PersistentBlockState pv) + forall store m pv v. + (SupportsPersistentState store pv m, Wasm.IsWasmVersion v) => + PersistentBlockState store pv -> + NewInstanceData store (Modules.PersistentInstrumentedModuleV store v) v -> + m (ContractAddress, PersistentBlockState store pv) doPutNewInstance pbs NewInstanceData{..} = do bsp <- loadPBS pbs mods <- refLoad (bspModules bsp) @@ -3132,14 +3184,14 @@ doPutNewInstance pbs NewInstanceData{..} = do ) doModifyInstance :: - forall pv m v. - (SupportsPersistentState pv m, Wasm.IsWasmVersion v) => - PersistentBlockState pv -> + forall store pv m v. + (SupportsPersistentState store pv m, Wasm.IsWasmVersion v) => + PersistentBlockState store pv -> ContractAddress -> AmountDelta -> - Maybe (UpdatableContractState v) -> - Maybe (GSWasm.ModuleInterfaceA (Modules.PersistentInstrumentedModuleV v), Set.Set Wasm.ReceiveName) -> - m (PersistentBlockState pv) + Maybe (UpdatableContractState store v) -> + Maybe (GSWasm.ModuleInterfaceA (Modules.PersistentInstrumentedModuleV store v), Set.Set Wasm.ReceiveName) -> + m (PersistentBlockState store pv) doModifyInstance pbs caddr deltaAmnt val newModule = do bsp <- loadPBS pbs -- Update the instance @@ -3148,7 +3200,7 @@ doModifyInstance pbs caddr deltaAmnt val newModule = do Just (_, insts) -> storePBS pbs bsp{bspInstances = insts} where - upd :: BlockStatePointers pv -> PersistentInstance pv -> m ((), PersistentInstance pv) + upd :: BlockStatePointers store pv -> PersistentInstance store pv -> m ((), PersistentInstance store pv) upd _ (PersistentInstanceV0 oldInst) = case Wasm.getWasmVersion @v of Wasm.SV0 -> do -- V0 instances cannot be upgraded, so we don't need to do any @@ -3271,19 +3323,19 @@ doModifyInstance pbs caddr deltaAmnt val newModule = do rehashV1 Nothing iph inst@PersistentInstanceV{..} = (\newHash -> ((), PersistentInstanceV1 inst{pinstanceHash = newHash})) <$> Instances.makeInstanceHashV1State iph pinstanceModel pinstanceAmount -doGetIdentityProvider :: (SupportsPersistentState pv m) => PersistentBlockState pv -> ID.IdentityProviderIdentity -> m (Maybe IPS.IpInfo) +doGetIdentityProvider :: (SupportsPersistentState store pv m) => PersistentBlockState store pv -> ID.IdentityProviderIdentity -> m (Maybe IPS.IpInfo) doGetIdentityProvider pbs ipId = do bsp <- loadPBS pbs ips <- refLoad (bspIdentityProviders bsp) return $! IPS.idProviders ips ^? ix ipId -doGetAllIdentityProvider :: (SupportsPersistentState pv m) => PersistentBlockState pv -> m [IPS.IpInfo] +doGetAllIdentityProvider :: (SupportsPersistentState store pv m) => PersistentBlockState store pv -> m [IPS.IpInfo] doGetAllIdentityProvider pbs = do bsp <- loadPBS pbs ips <- refLoad (bspIdentityProviders bsp) return $! Map.elems $ IPS.idProviders ips -doGetAnonymityRevokers :: (SupportsPersistentState pv m) => PersistentBlockState pv -> [ID.ArIdentity] -> m (Maybe [ARS.ArInfo]) +doGetAnonymityRevokers :: (SupportsPersistentState store pv m) => PersistentBlockState store pv -> [ID.ArIdentity] -> m (Maybe [ARS.ArInfo]) doGetAnonymityRevokers pbs arIds = do bsp <- loadPBS pbs ars <- refLoad (bspAnonymityRevokers bsp) @@ -3291,30 +3343,30 @@ doGetAnonymityRevokers pbs arIds = do let arsMap = ARS.arRevokers ars in forM arIds (`Map.lookup` arsMap) -doGetAllAnonymityRevokers :: (SupportsPersistentState pv m) => PersistentBlockState pv -> m [ARS.ArInfo] +doGetAllAnonymityRevokers :: (SupportsPersistentState store pv m) => PersistentBlockState store pv -> m [ARS.ArInfo] doGetAllAnonymityRevokers pbs = do bsp <- loadPBS pbs ars <- refLoad (bspAnonymityRevokers bsp) return $! Map.elems $ ARS.arRevokers ars -doGetCryptoParams :: (SupportsPersistentState pv m) => PersistentBlockState pv -> m CryptographicParameters +doGetCryptoParams :: (SupportsPersistentState store pv m) => PersistentBlockState store pv -> m CryptographicParameters doGetCryptoParams pbs = do bsp <- loadPBS pbs refLoad (bspCryptographicParameters bsp) -doGetPaydayEpoch :: forall pv m. (SupportsPersistentState pv m, PVSupportsDelegation pv) => PersistentBlockState pv -> m Epoch +doGetPaydayEpoch :: forall store pv m. (SupportsPersistentState store pv m, PVSupportsDelegation pv) => PersistentBlockState store pv -> m Epoch doGetPaydayEpoch pbs = do bsp <- loadPBS pbs case bspRewardDetails bsp of BlockRewardDetailsV1 hpr -> nextPaydayEpoch <$> refLoad hpr -doGetPaydayMintRate :: forall pv m. (SupportsPersistentState pv m, PVSupportsDelegation pv) => PersistentBlockState pv -> m MintRate +doGetPaydayMintRate :: forall store pv m. (SupportsPersistentState store pv m, PVSupportsDelegation pv) => PersistentBlockState store pv -> m MintRate doGetPaydayMintRate pbs = do bsp <- loadPBS pbs case bspRewardDetails bsp of BlockRewardDetailsV1 hpr -> nextPaydayMintRate <$> refLoad hpr -doSetPaydayEpoch :: forall pv m. (SupportsPersistentState pv m, PVSupportsDelegation pv) => PersistentBlockState pv -> Epoch -> m (PersistentBlockState pv) +doSetPaydayEpoch :: forall store pv m. (SupportsPersistentState store pv m, PVSupportsDelegation pv) => PersistentBlockState store pv -> Epoch -> m (PersistentBlockState store pv) doSetPaydayEpoch pbs e = do bsp <- loadPBS pbs case bspRewardDetails bsp of @@ -3323,7 +3375,7 @@ doSetPaydayEpoch pbs e = do hpr' <- refMake pr{nextPaydayEpoch = e} storePBS pbs bsp{bspRewardDetails = BlockRewardDetailsV1 hpr'} -doSetPaydayMintRate :: forall pv m. (SupportsPersistentState pv m, PVSupportsDelegation pv) => PersistentBlockState pv -> MintRate -> m (PersistentBlockState pv) +doSetPaydayMintRate :: forall store pv m. (SupportsPersistentState store pv m, PVSupportsDelegation pv) => PersistentBlockState store pv -> MintRate -> m (PersistentBlockState store pv) doSetPaydayMintRate pbs r = do bsp <- loadPBS pbs case bspRewardDetails bsp of @@ -3335,9 +3387,9 @@ doSetPaydayMintRate pbs r = do -- | Get the status of passive delegation. -- Used to implement 'getPassiveDelegationStatus'. doGetPassiveDelegationStatus :: - forall pv m. - (IsProtocolVersion pv, SupportsPersistentState pv m, PVSupportsDelegation pv) => - PersistentBlockState pv -> + forall store pv m. + (IsProtocolVersion pv, SupportsPersistentState store pv m, PVSupportsDelegation pv) => + PersistentBlockState store pv -> m PassiveDelegationStatus doGetPassiveDelegationStatus pbs = case delegationChainParameters @pv of DelegationChainParameters -> do @@ -3354,12 +3406,12 @@ doGetPassiveDelegationStatus pbs = case delegationChainParameters @pv of -- 'Nothing' if the 'BakerId' is not an active or current-epoch baker. -- Used to implement 'getPoolStatus'. doGetPoolStatus :: - forall pv m. + forall store pv m. ( IsProtocolVersion pv, - SupportsPersistentState pv m, + SupportsPersistentState store pv m, PVSupportsDelegation pv ) => - PersistentBlockState pv -> + PersistentBlockState store pv -> BakerId -> m (Maybe BakerPoolStatus) doGetPoolStatus pbs psBakerId@(BakerId aid) = case delegationChainParameters @pv of @@ -3429,7 +3481,10 @@ doGetPoolStatus pbs psBakerId@(BakerId aid) = case delegationChainParameters @pv then return $ Just BakerPoolStatus{..} else return Nothing -doGetTransactionOutcome :: forall tov pv m. (SupportsPersistentState pv m, TransactionOutcomesVersionFor pv ~ tov) => PersistentBlockState pv -> Transactions.TransactionIndex -> m (Maybe (TransactionSummary tov)) +doGetTransactionOutcome :: + forall store tov pv m. + (SupportsPersistentState store pv m, TransactionOutcomesVersionFor pv ~ tov) => + PersistentBlockState store pv -> Transactions.TransactionIndex -> m (Maybe (TransactionSummary tov)) doGetTransactionOutcome pbs transHash = do bsp <- loadPBS pbs case bspTransactionOutcomes bsp of @@ -3439,16 +3494,19 @@ doGetTransactionOutcome pbs transHash = do PTOV3 bto -> fmap _transactionSummaryV1 <$> LFMBT.lookup transHash (mtoOutcomes bto) doGetTransactionOutcomesHash :: - forall pv m. - (SupportsPersistentState pv m) => - PersistentBlockState pv -> + forall store pv m. + (SupportsPersistentState store pv m) => + PersistentBlockState store pv -> m TransactionOutcomes.TransactionOutcomesHash doGetTransactionOutcomesHash pbs = do bsp <- loadPBS pbs TransactionOutcomes.toTransactionOutcomesHash @(TransactionOutcomesVersionFor pv) <$> getHashM (bspTransactionOutcomes bsp) -doSetTransactionOutcomes :: forall tov pv m. (SupportsPersistentState pv m, tov ~ TransactionOutcomesVersionFor pv) => PersistentBlockState pv -> [TransactionSummary tov] -> m (PersistentBlockState pv) +doSetTransactionOutcomes :: + forall store tov pv m. + (SupportsPersistentState store pv m, tov ~ TransactionOutcomesVersionFor pv) => + PersistentBlockState store pv -> [TransactionSummary tov] -> m (PersistentBlockState store pv) doSetTransactionOutcomes pbs transList = do bsp <- loadPBS pbs case bspTransactionOutcomes bsp of @@ -3469,17 +3527,17 @@ doSetTransactionOutcomes pbs transList = do mto <- makeMTO storePBS pbs bsp{bspTransactionOutcomes = PTOV3 mto} where - makeMTO :: m (MerkleTransactionOutcomes tov) + makeMTO :: m (MerkleTransactionOutcomes store tov) makeMTO = do mtoOutcomes <- LFMBT.fromAscList . map TransactionSummaryV1 $ transList return MerkleTransactionOutcomes{mtoSpecials = LFMBT.empty, ..} -doNotifyEncryptedBalanceChange :: (SupportsPersistentState pv m) => PersistentBlockState pv -> AmountDelta -> m (PersistentBlockState pv) +doNotifyEncryptedBalanceChange :: (SupportsPersistentState store pv m) => PersistentBlockState store pv -> AmountDelta -> m (PersistentBlockState store pv) doNotifyEncryptedBalanceChange pbs amntDiff = do bsp <- loadPBS pbs storePBS pbs bsp{bspBank = bspBank bsp & unhashed . Rewards.totalEncryptedGTU %~ applyAmountDelta amntDiff} -doGetSpecialOutcomes :: (SupportsPersistentState pv m, MonadProtocolVersion m) => PersistentBlockState pv -> m (Seq.Seq Transactions.SpecialTransactionOutcome) +doGetSpecialOutcomes :: (SupportsPersistentState store pv m, MonadProtocolVersion m) => PersistentBlockState store pv -> m (Seq.Seq Transactions.SpecialTransactionOutcome) doGetSpecialOutcomes pbs = do bsp <- loadPBS pbs case bspTransactionOutcomes bsp of @@ -3488,7 +3546,7 @@ doGetSpecialOutcomes pbs = do PTOV2 bto -> Seq.fromList <$> LFMBT.toAscList (mtoSpecials bto) PTOV3 bto -> Seq.fromList <$> LFMBT.toAscList (mtoSpecials bto) -doGetOutcomes :: (SupportsPersistentState pv m, MonadProtocolVersion m) => PersistentBlockState pv -> m (Vec.Vector (TransactionSummary (TransactionOutcomesVersionFor pv))) +doGetOutcomes :: (SupportsPersistentState store pv m, MonadProtocolVersion m) => PersistentBlockState store pv -> m (Vec.Vector (TransactionSummary (TransactionOutcomesVersionFor pv))) doGetOutcomes pbs = do bsp <- loadPBS pbs case bspTransactionOutcomes bsp of @@ -3497,7 +3555,7 @@ doGetOutcomes pbs = do PTOV2 bto -> Vec.fromList . map _transactionSummaryV1 <$> LFMBT.toAscList (mtoOutcomes bto) PTOV3 bto -> Vec.fromList . map _transactionSummaryV1 <$> LFMBT.toAscList (mtoOutcomes bto) -doAddSpecialTransactionOutcome :: (SupportsPersistentState pv m, MonadProtocolVersion m) => PersistentBlockState pv -> Transactions.SpecialTransactionOutcome -> m (PersistentBlockState pv) +doAddSpecialTransactionOutcome :: (SupportsPersistentState store pv m, MonadProtocolVersion m) => PersistentBlockState store pv -> Transactions.SpecialTransactionOutcome -> m (PersistentBlockState store pv) doAddSpecialTransactionOutcome pbs !o = do bsp <- loadPBS pbs case bspTransactionOutcomes bsp of @@ -3518,50 +3576,50 @@ doAddSpecialTransactionOutcome pbs !o = do storePBS pbs $! bsp{bspTransactionOutcomes = PTOV3 (bto{mtoSpecials = newSpecials})} doGetElectionDifficulty :: - ( SupportsPersistentState pv m, + ( SupportsPersistentState store pv m, ConsensusParametersVersionFor (ChainParametersVersionFor pv) ~ 'ConsensusParametersVersion0 ) => - PersistentBlockState pv -> + PersistentBlockState store pv -> Timestamp -> m ElectionDifficulty doGetElectionDifficulty pbs ts = do bsp <- loadPBS pbs futureElectionDifficulty (bspUpdates bsp) ts -doGetNextUpdateSequenceNumber :: (SupportsPersistentState pv m) => PersistentBlockState pv -> UpdateType -> m UpdateSequenceNumber +doGetNextUpdateSequenceNumber :: (SupportsPersistentState store pv m) => PersistentBlockState store pv -> UpdateType -> m UpdateSequenceNumber doGetNextUpdateSequenceNumber pbs uty = do bsp <- loadPBS pbs lookupNextUpdateSequenceNumber (bspUpdates bsp) uty doGetCurrentElectionDifficulty :: - ( SupportsPersistentState pv m, + ( SupportsPersistentState store pv m, ConsensusParametersVersionFor (ChainParametersVersionFor pv) ~ 'ConsensusParametersVersion0 ) => - PersistentBlockState pv -> + PersistentBlockState store pv -> m ElectionDifficulty doGetCurrentElectionDifficulty pbs = do bsp <- loadPBS pbs upds <- refLoad (bspUpdates bsp) _cpElectionDifficulty . _cpConsensusParameters . unStoreSerialized <$> refLoad (currentParameters upds) -doGetUpdates :: (SupportsPersistentState pv m) => PersistentBlockState pv -> m (UQ.Updates pv) +doGetUpdates :: (SupportsPersistentState store pv m) => PersistentBlockState store pv -> m (UQ.Updates pv) doGetUpdates = makeBasicUpdates <=< refLoad . bspUpdates <=< loadPBS -doGetProtocolUpdateStatus :: (SupportsPersistentState pv m) => PersistentBlockState pv -> m UQ.ProtocolUpdateStatus +doGetProtocolUpdateStatus :: (SupportsPersistentState store pv m) => PersistentBlockState store pv -> m UQ.ProtocolUpdateStatus doGetProtocolUpdateStatus = protocolUpdateStatus . bspUpdates <=< loadPBS -doIsProtocolUpdateEffective :: (SupportsPersistentState pv m) => PersistentBlockState pv -> m Bool +doIsProtocolUpdateEffective :: (SupportsPersistentState store pv m) => PersistentBlockState store pv -> m Bool doIsProtocolUpdateEffective = isProtocolUpdateEffective . bspUpdates <=< loadPBS doUpdateMissedRounds :: ( PVSupportsDelegation pv, - SupportsPersistentState pv m + SupportsPersistentState store pv m ) => - PersistentBlockState pv -> + PersistentBlockState store pv -> Map.Map BakerId Word64 -> - m (PersistentBlockState pv) + m (PersistentBlockState store pv) doUpdateMissedRounds pbs rds = do bsp <- loadPBS pbs bsp' <- @@ -3587,11 +3645,11 @@ doUpdateMissedRounds pbs rds = do -- suspension. doPrimeForSuspension :: ( PVSupportsDelegation pv, - SupportsPersistentState pv m + SupportsPersistentState store pv m ) => - PersistentBlockState pv -> + PersistentBlockState store pv -> Word64 -> - m ([BakerId], PersistentBlockState pv) + m ([BakerId], PersistentBlockState store pv) doPrimeForSuspension pbs threshold = do bprds <- doGetBakerPoolRewardDetails pbs bsp0 <- loadPBS pbs @@ -3620,11 +3678,11 @@ doPrimeForSuspension pbs threshold = do -- Returns the subset of account indices that were suspended together with their canonical account -- addresses. doSuspendValidators :: - forall pv m. - (SupportsPersistentState pv m) => - PersistentBlockState pv -> + forall store pv m. + (SupportsPersistentState store pv m) => + PersistentBlockState store pv -> [AccountIndex] -> - m ([(AccountIndex, AccountAddress)], PersistentBlockState pv) + m ([(AccountIndex, AccountAddress)], PersistentBlockState store pv) doSuspendValidators pbs ais = case hasValidatorSuspension of STrue -> do @@ -3659,18 +3717,21 @@ doSuspendValidators pbs ais = hasValidatorSuspension = sSupportsValidatorSuspension (accountVersion @(AccountVersionFor pv)) doProcessUpdateQueues :: - forall pv m. - (SupportsPersistentState pv m) => - PersistentBlockState pv -> + forall store pv m. + (SupportsPersistentState store pv m) => + PersistentBlockState store pv -> Timestamp -> - m ([(TransactionTime, UpdateValue (ChainParametersVersionFor pv) (AuthorizationsVersionFor pv))], PersistentBlockState pv) + m ([(TransactionTime, UpdateValue (ChainParametersVersionFor pv) (AuthorizationsVersionFor pv))], PersistentBlockState store pv) doProcessUpdateQueues pbs ts = do bsp <- loadPBS pbs let (u, ars, ips) = (bspUpdates bsp, bspAnonymityRevokers bsp, bspIdentityProviders bsp) (changes, (u', ars', ips')) <- processUpdateQueues ts (u, ars, ips) (changes,) <$> storePBS pbs bsp{bspUpdates = u', bspAnonymityRevokers = ars', bspIdentityProviders = ips'} -doProcessReleaseSchedule :: forall m pv. (SupportsPersistentState pv m) => PersistentBlockState pv -> Timestamp -> m (PersistentBlockState pv) +doProcessReleaseSchedule :: + forall store m pv. + (SupportsPersistentState store pv m) => + PersistentBlockState store pv -> Timestamp -> m (PersistentBlockState store pv) doProcessReleaseSchedule pbs ts = do bsp <- loadPBS pbs (affectedAccounts, remRS) <- processReleasesUntil ts (bspReleaseSchedule bsp) @@ -3679,9 +3740,9 @@ doProcessReleaseSchedule pbs ts = do else do let processAccountP1 :: (RSAccountRef pv ~ AccountAddress) => - (Accounts.Accounts pv, ReleaseSchedule pv) -> + (Accounts.Accounts store pv, ReleaseSchedule store pv) -> RSAccountRef pv -> - m (Accounts.Accounts pv, ReleaseSchedule pv) + m (Accounts.Accounts store pv, ReleaseSchedule store pv) processAccountP1 (accs, rs) addr = do (reAdd, accs') <- Accounts.updateAccounts (unlockAccountReleases ts) addr accs rs' <- case reAdd of @@ -3691,9 +3752,9 @@ doProcessReleaseSchedule pbs ts = do return (accs', rs') processAccountP5 :: (RSAccountRef pv ~ AccountIndex) => - (Accounts.Accounts pv, ReleaseSchedule pv) -> + (Accounts.Accounts store pv, ReleaseSchedule store pv) -> RSAccountRef pv -> - m (Accounts.Accounts pv, ReleaseSchedule pv) + m (Accounts.Accounts store pv, ReleaseSchedule store pv) processAccountP5 (accs, rs) ai = do (reAdd, accs') <- Accounts.updateAccountsAtIndex (unlockAccountReleases ts) ai accs rs' <- case reAdd of @@ -3701,7 +3762,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.Accounts store pv, ReleaseSchedule store pv) -> RSAccountRef pv -> m (Accounts.Accounts store pv, ReleaseSchedule store pv) processAccount = case protocolVersion @pv of SP1 -> processAccountP1 SP2 -> processAccountP1 @@ -3717,9 +3778,9 @@ doProcessReleaseSchedule pbs ts = do storePBS pbs (bsp{bspAccounts = newAccs, bspReleaseSchedule = newRS}) doGetUpdateKeyCollection :: - forall pv m. - (SupportsPersistentState pv m) => - PersistentBlockState pv -> + forall store pv m. + (SupportsPersistentState store pv m) => + PersistentBlockState store pv -> m (UpdateKeysCollection (AuthorizationsVersionFor pv)) doGetUpdateKeyCollection pbs = do bsp <- loadPBS pbs @@ -3728,21 +3789,21 @@ doGetUpdateKeyCollection pbs = do unStoreSerialized <$> refLoad (currentKeyCollection u) doEnqueueUpdate :: - (SupportsPersistentState pv m) => - PersistentBlockState pv -> + (SupportsPersistentState store pv m) => + PersistentBlockState store pv -> TransactionTime -> UpdateValue (ChainParametersVersionFor pv) (AuthorizationsVersionFor pv) -> - m (PersistentBlockState pv) + m (PersistentBlockState store pv) doEnqueueUpdate pbs effectiveTime payload = do bsp <- loadPBS pbs u' <- enqueueUpdate effectiveTime payload (bspUpdates bsp) storePBS pbs bsp{bspUpdates = u'} doIncrementPLTUpdateSequenceNumber :: - forall pv m. - (SupportsPersistentState pv m, PVSupportsPLT pv) => - PersistentBlockState pv -> - m (PersistentBlockState pv) + forall store pv m. + (SupportsPersistentState store pv m, PVSupportsPLT pv) => + PersistentBlockState store pv -> + m (PersistentBlockState store pv) doIncrementPLTUpdateSequenceNumber pbs = case sSupportsCreatePLT (sAuthorizationsVersionFor (protocolVersion @pv)) of SFalse -> case protocolVersion @pv of {} @@ -3752,31 +3813,31 @@ doIncrementPLTUpdateSequenceNumber pbs = storePBS pbs bsp{bspUpdates = u'} doOverwriteElectionDifficulty :: - ( SupportsPersistentState pv m, + ( SupportsPersistentState store pv m, ConsensusParametersVersionFor (ChainParametersVersionFor pv) ~ 'ConsensusParametersVersion0 ) => - PersistentBlockState pv -> + PersistentBlockState store pv -> ElectionDifficulty -> - m (PersistentBlockState pv) + m (PersistentBlockState store pv) doOverwriteElectionDifficulty pbs newElectionDifficulty = do bsp <- loadPBS pbs u' <- overwriteElectionDifficulty newElectionDifficulty (bspUpdates bsp) storePBS pbs bsp{bspUpdates = u'} -doClearProtocolUpdate :: (SupportsPersistentState pv m) => PersistentBlockState pv -> m (PersistentBlockState pv) +doClearProtocolUpdate :: (SupportsPersistentState store pv m) => PersistentBlockState store pv -> m (PersistentBlockState store pv) doClearProtocolUpdate pbs = do bsp <- loadPBS pbs u' <- clearProtocolUpdate (bspUpdates bsp) storePBS pbs bsp{bspUpdates = u'} doSetNextCapitalDistribution :: - forall pv m. - (SupportsPersistentState pv m, PVSupportsDelegation pv) => - PersistentBlockState pv -> + forall store pv m. + (SupportsPersistentState store pv m, PVSupportsDelegation pv) => + PersistentBlockState store pv -> CapitalDistribution -> - m (PersistentBlockState pv) + m (PersistentBlockState store pv) doSetNextCapitalDistribution pbs cd = do bsp <- loadPBS pbs capDist <- refMake cd @@ -3787,36 +3848,36 @@ doSetNextCapitalDistribution pbs cd = do storePBS pbs bsp{bspRewardDetails = newRewardDetails} doRotateCurrentCapitalDistribution :: - (SupportsPersistentState pv m, PVSupportsDelegation pv) => - PersistentBlockState pv -> - m (PersistentBlockState pv) + (SupportsPersistentState store pv m, PVSupportsDelegation pv) => + PersistentBlockState store pv -> + m (PersistentBlockState store pv) doRotateCurrentCapitalDistribution pbs = do bsp <- loadPBS pbs newRewardDetails <- case bspRewardDetails bsp of BlockRewardDetailsV1 hpr -> BlockRewardDetailsV1 <$> rotateCapitalDistribution hpr storePBS pbs bsp{bspRewardDetails = newRewardDetails} -doGetExchangeRates :: (SupportsPersistentState pv m) => PersistentBlockState pv -> m ExchangeRates +doGetExchangeRates :: (SupportsPersistentState store pv m) => PersistentBlockState store pv -> m ExchangeRates doGetExchangeRates pbs = do bsp <- loadPBS pbs lookupExchangeRates (bspUpdates bsp) -doGetChainParameters :: (SupportsPersistentState pv m) => PersistentBlockState pv -> m (ChainParameters pv) +doGetChainParameters :: (SupportsPersistentState store pv m) => PersistentBlockState store pv -> m (ChainParameters pv) doGetChainParameters pbs = do bsp <- loadPBS pbs lookupCurrentParameters (bspUpdates bsp) -doGetPendingTimeParameters :: (SupportsPersistentState pv m) => PersistentBlockState pv -> m [(TransactionTime, TimeParameters)] +doGetPendingTimeParameters :: (SupportsPersistentState store pv m) => PersistentBlockState store pv -> m [(TransactionTime, TimeParameters)] doGetPendingTimeParameters pbs = do bsp <- loadPBS pbs lookupPendingTimeParameters (bspUpdates bsp) -doGetPendingPoolParameters :: (SupportsPersistentState pv m) => PersistentBlockState pv -> m [(TransactionTime, PoolParameters (ChainParametersVersionFor pv))] +doGetPendingPoolParameters :: (SupportsPersistentState store pv m) => PersistentBlockState store pv -> m [(TransactionTime, PoolParameters (ChainParametersVersionFor pv))] doGetPendingPoolParameters pbs = do bsp <- loadPBS pbs lookupPendingPoolParameters (bspUpdates bsp) -doGetEpochBlocksBaked :: (SupportsPersistentState pv m) => PersistentBlockState pv -> m (Word64, [(BakerId, Word64)]) +doGetEpochBlocksBaked :: (SupportsPersistentState store pv m) => PersistentBlockState store pv -> m (Word64, [(BakerId, Word64)]) doGetEpochBlocksBaked pbs = do bsp <- loadPBS pbs case bspRewardDetails bsp of @@ -3836,7 +3897,7 @@ doGetEpochBlocksBaked pbs = do -- | This function updates the baker pool rewards details of a baker. It is a precondition that -- the given baker is active. -modifyBakerPoolRewardDetailsInPoolRewards :: (SupportsPersistentAccount pv m, PVSupportsDelegation pv) => BlockStatePointers pv -> BakerId -> ((BakerPoolRewardDetails (AccountVersionFor pv)) -> (BakerPoolRewardDetails (AccountVersionFor pv))) -> m (BlockStatePointers pv) +modifyBakerPoolRewardDetailsInPoolRewards :: (SupportsPersistentAccount store pv m, PVSupportsDelegation pv) => BlockStatePointers store pv -> BakerId -> ((BakerPoolRewardDetails (AccountVersionFor pv)) -> (BakerPoolRewardDetails (AccountVersionFor pv))) -> m (BlockStatePointers store pv) modifyBakerPoolRewardDetailsInPoolRewards bsp bid f = do let hpr = case bspRewardDetails bsp of BlockRewardDetailsV1 hp -> hp pr <- refLoad hpr @@ -3858,7 +3919,7 @@ modifyBakerPoolRewardDetailsInPoolRewards bsp bid f = do Just ((), newBPRs) -> return newBPRs -doNotifyBlockBaked :: forall pv m. (SupportsPersistentState pv m) => PersistentBlockState pv -> BakerId -> m (PersistentBlockState pv) +doNotifyBlockBaked :: forall store pv m. (SupportsPersistentState store pv m) => PersistentBlockState store pv -> BakerId -> m (PersistentBlockState store pv) doNotifyBlockBaked pbs bid = do bsp <- loadPBS pbs case delegationSupport @(AccountVersionFor pv) of @@ -3873,13 +3934,13 @@ doNotifyBlockBaked pbs bid = do } in storePBS pbs =<< modifyBakerPoolRewardDetailsInPoolRewards bsp bid incBPR -doUpdateAccruedTransactionFeesBaker :: forall pv m. (PVSupportsDelegation pv, SupportsPersistentState pv m) => PersistentBlockState pv -> BakerId -> AmountDelta -> m (PersistentBlockState pv) +doUpdateAccruedTransactionFeesBaker :: forall store pv m. (PVSupportsDelegation pv, SupportsPersistentState store pv m) => PersistentBlockState store pv -> BakerId -> AmountDelta -> m (PersistentBlockState store pv) doUpdateAccruedTransactionFeesBaker pbs bid delta = do bsp <- loadPBS pbs let accrueAmountBPR bpr = bpr{transactionFeesAccrued = applyAmountDelta delta (transactionFeesAccrued bpr)} storePBS pbs =<< modifyBakerPoolRewardDetailsInPoolRewards bsp bid accrueAmountBPR -doMarkFinalizationAwakeBakers :: forall pv m. (SupportsPersistentState pv m, PVSupportsDelegation pv) => PersistentBlockState pv -> [BakerId] -> m (PersistentBlockState pv) +doMarkFinalizationAwakeBakers :: forall store pv m. (SupportsPersistentState store pv m, PVSupportsDelegation pv) => PersistentBlockState store pv -> [BakerId] -> m (PersistentBlockState store pv) doMarkFinalizationAwakeBakers pbs bids = do bsp <- loadPBS pbs let hpr = case bspRewardDetails bsp of BlockRewardDetailsV1 hp -> hp @@ -3922,7 +3983,7 @@ doMarkFinalizationAwakeBakers pbs bids = do } ) -doUpdateAccruedTransactionFeesPassive :: forall pv m. (PVSupportsDelegation pv, SupportsPersistentState pv m) => PersistentBlockState pv -> AmountDelta -> m (PersistentBlockState pv) +doUpdateAccruedTransactionFeesPassive :: forall store pv m. (PVSupportsDelegation pv, SupportsPersistentState store pv m) => PersistentBlockState store pv -> AmountDelta -> m (PersistentBlockState store pv) doUpdateAccruedTransactionFeesPassive pbs delta = do bsp <- loadPBS pbs let hpr = case bspRewardDetails bsp of BlockRewardDetailsV1 hp -> hp @@ -3935,13 +3996,13 @@ doUpdateAccruedTransactionFeesPassive pbs delta = do } storePBS pbs $ bsp{bspRewardDetails = newBlockRewardDetails} -doGetAccruedTransactionFeesPassive :: forall pv m. (SupportsPersistentState pv m, PVSupportsDelegation pv) => PersistentBlockState pv -> m Amount +doGetAccruedTransactionFeesPassive :: forall store pv m. (SupportsPersistentState store pv m, PVSupportsDelegation pv) => PersistentBlockState store pv -> m Amount doGetAccruedTransactionFeesPassive pbs = do bsp <- loadPBS pbs let hpr = case bspRewardDetails bsp of BlockRewardDetailsV1 hp -> hp passiveDelegationTransactionRewards <$> refLoad hpr -doUpdateAccruedTransactionFeesFoundationAccount :: forall pv m. (SupportsPersistentState pv m, PVSupportsDelegation pv) => PersistentBlockState pv -> AmountDelta -> m (PersistentBlockState pv) +doUpdateAccruedTransactionFeesFoundationAccount :: forall store pv m. (SupportsPersistentState store pv m, PVSupportsDelegation pv) => PersistentBlockState store pv -> AmountDelta -> m (PersistentBlockState store pv) doUpdateAccruedTransactionFeesFoundationAccount pbs delta = do bsp <- loadPBS pbs let hpr = case bspRewardDetails bsp of BlockRewardDetailsV1 hp -> hp @@ -3954,22 +4015,22 @@ doUpdateAccruedTransactionFeesFoundationAccount pbs delta = do } storePBS pbs $ bsp{bspRewardDetails = newBlockRewardDetails} -doGetAccruedTransactionFeesFoundationAccount :: forall pv m. (SupportsPersistentState pv m, PVSupportsDelegation pv) => PersistentBlockState pv -> m Amount +doGetAccruedTransactionFeesFoundationAccount :: forall store pv m. (SupportsPersistentState store pv m, PVSupportsDelegation pv) => PersistentBlockState store pv -> m Amount doGetAccruedTransactionFeesFoundationAccount pbs = do bsp <- loadPBS pbs let hpr = case bspRewardDetails bsp of BlockRewardDetailsV1 hp -> hp foundationTransactionRewards <$> refLoad hpr -doClearEpochBlocksBaked :: (SupportsPersistentState pv m) => PersistentBlockState pv -> m (PersistentBlockState pv) +doClearEpochBlocksBaked :: (SupportsPersistentState store pv m) => PersistentBlockState store pv -> m (PersistentBlockState store pv) doClearEpochBlocksBaked pbs = do bsp <- loadPBS pbs rewardDetails <- emptyBlockRewardDetails storePBS pbs bsp{bspRewardDetails = rewardDetails} doRotateCurrentEpochBakers :: - (SupportsPersistentState pv m) => - PersistentBlockState pv -> - m (PersistentBlockState pv) + (SupportsPersistentState store pv m) => + PersistentBlockState store pv -> + m (PersistentBlockState store pv) doRotateCurrentEpochBakers pbs = do bsp <- loadPBS pbs let oldBirkParams = bspBirkParameters bsp @@ -3977,11 +4038,11 @@ doRotateCurrentEpochBakers pbs = do storePBS pbs bsp{bspBirkParameters = newBirkParams} doSetNextEpochBakers :: - (SupportsPersistentState pv m) => - PersistentBlockState pv -> - [(PersistentBakerInfoRef (AccountVersionFor pv), Amount)] -> + (SupportsPersistentState store pv m) => + PersistentBlockState store pv -> + [(PersistentBakerInfoRef store (AccountVersionFor pv), Amount)] -> OFinalizationCommitteeParameters pv -> - m (PersistentBlockState pv) + m (PersistentBlockState store pv) doSetNextEpochBakers pbs bakers _bakerFinalizationCommitteeParameters = do bsp <- loadPBS pbs _bakerInfos <- refMake (BakerInfos preBakerInfos) @@ -3996,12 +4057,12 @@ doSetNextEpochBakers pbs bakers _bakerFinalizationCommitteeParameters = do preBakerStakes = snd <$> bakers' doProcessPendingChanges :: - forall pv m. - (SupportsPersistentState pv m, PVSupportsDelegation pv) => - PersistentBlockState pv -> + forall store pv m. + (SupportsPersistentState store pv m, PVSupportsDelegation pv) => + PersistentBlockState store pv -> -- | Guard determining if a change is effective (Timestamp -> Bool) -> - m (PersistentBlockState pv) + m (PersistentBlockState store pv) doProcessPendingChanges persistentBS isEffective = do bsp <- loadPBS persistentBS newBSP <- processPendingChanges bsp @@ -4043,8 +4104,8 @@ doProcessPendingChanges persistentBS isEffective = do -- in the process. This does not update the active bakers, but should be used to modify -- an entry for a particular pool. processDelegators :: - PersistentActiveDelegators (AccountVersionFor pv) -> - MTL.StateT (Accounts.Accounts pv) m (PersistentActiveDelegators (AccountVersionFor pv)) + PersistentActiveDelegators store (AccountVersionFor pv) -> + MTL.StateT (Accounts.Accounts store pv) m (PersistentActiveDelegators store (AccountVersionFor pv)) processDelegators (PersistentActiveDelegatorsV1 dset _) = do (newDlgs, newAmt) <- MTL.runWriterT $ Trie.filterKeysM processDelegator dset return (PersistentActiveDelegatorsV1 newDlgs newAmt) @@ -4052,7 +4113,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.Accounts store pv) m) Bool processDelegator (DelegatorId accId) = do accounts <- MTL.get Accounts.indexedAccount accId accounts >>= \case @@ -4065,8 +4126,8 @@ doProcessPendingChanges persistentBS isEffective = do -- The boolean return value indicates if the delegator is still a delegator. updateAccountDelegator :: AccountIndex -> - PersistentAccount (AccountVersionFor pv) -> - MTL.WriterT Amount (MTL.StateT (Accounts.Accounts pv) m) Bool + PersistentAccount store (AccountVersionFor pv) -> + MTL.WriterT Amount (MTL.StateT (Accounts.Accounts store pv) m) Bool updateAccountDelegator accId acct = accountDelegator acct >>= \case Just BaseAccounts.AccountDelegationV1{..} -> do @@ -4087,7 +4148,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.Accounts store pv) m () removeDelegatorStake accId = do accounts <- MTL.get newAccounts <- Accounts.updateAccountsAtIndex' removeAccountStaking accId accounts @@ -4099,7 +4160,7 @@ doProcessPendingChanges persistentBS isEffective = do reduceDelegatorStake :: AccountIndex -> Amount -> - MTL.StateT (Accounts.Accounts pv) m () + MTL.StateT (Accounts.Accounts store pv) m () reduceDelegatorStake accId newAmt = do accounts <- MTL.get let updAcc = setAccountStake newAmt >=> setAccountStakePendingChange BaseAccounts.NoChange @@ -4112,11 +4173,11 @@ doProcessPendingChanges persistentBS isEffective = do -- The new total capital staked by the bakers and their original delegators is returned. -- (Note that stakes may have been reduced or removed, or moved to passive delegation.) processBakers :: - BakerIdTrieMap (AccountVersionFor pv) -> + BakerIdTrieMap store (AccountVersionFor pv) -> MTL.StateT - (Accounts.Accounts pv, AggregationKeySet, PersistentActiveDelegators (AccountVersionFor pv)) + (Accounts.Accounts store pv, AggregationKeySet store, PersistentActiveDelegators store (AccountVersionFor pv)) m - (BakerIdTrieMap (AccountVersionFor pv), Amount) + (BakerIdTrieMap store (AccountVersionFor pv), Amount) processBakers = MTL.runWriterT . Trie.alterMapM processBaker -- Process a baker's entry in the active baker pools table, updating the account table, @@ -4126,11 +4187,11 @@ doProcessPendingChanges persistentBS isEffective = do -- The return value indicates how the active baker pool table should be updated. processBaker :: BakerId -> - PersistentActiveDelegators (AccountVersionFor pv) -> + PersistentActiveDelegators store (AccountVersionFor pv) -> MTL.WriterT Amount - (MTL.StateT (Accounts.Accounts pv, AggregationKeySet, PersistentActiveDelegators (AccountVersionFor pv)) m) - (Trie.Alteration (PersistentActiveDelegators (AccountVersionFor pv))) + (MTL.StateT (Accounts.Accounts store pv, AggregationKeySet store, PersistentActiveDelegators store (AccountVersionFor pv)) m) + (Trie.Alteration (PersistentActiveDelegators store (AccountVersionFor pv))) processBaker bid@(BakerId accId) oldDelegators = do accts0 <- use _1 (newDelegators, accts1) <- lift $ lift $ MTL.runStateT (processDelegators oldDelegators) accts0 @@ -4175,8 +4236,8 @@ doProcessPendingChanges persistentBS isEffective = do removeBaker :: BakerId -> AccountBaker av -> - PersistentActiveDelegators (AccountVersionFor pv) -> - MTL.StateT (Accounts.Accounts pv, AggregationKeySet, PersistentActiveDelegators (AccountVersionFor pv)) m () + PersistentActiveDelegators store (AccountVersionFor pv) -> + MTL.StateT (Accounts.Accounts store pv, AggregationKeySet store, PersistentActiveDelegators store (AccountVersionFor pv)) m () removeBaker (BakerId accId) acctBkr (PersistentActiveDelegatorsV1 dset dcapital) = do accounts0 <- use _1 -- Update the baker's account to have no delegation @@ -4198,7 +4259,7 @@ doProcessPendingChanges persistentBS isEffective = do reduceBakerStake :: BakerId -> Amount -> - MTL.StateT (Accounts.Accounts pv, a, b) m () + MTL.StateT (Accounts.Accounts store pv, a, b) m () reduceBakerStake (BakerId accId) newAmt = do let updAcc = setAccountStake newAmt >=> setAccountStakePendingChange BaseAccounts.NoChange accounts <- use _1 @@ -4207,14 +4268,14 @@ doProcessPendingChanges persistentBS isEffective = do -- | Process cooldowns on accounts that have expired, and move pre-cooldowns into cooldown. doProcessCooldowns :: - forall pv m. - (SupportsPersistentState pv m, PVSupportsFlexibleCooldown pv) => - PersistentBlockState pv -> + forall store pv m. + (SupportsPersistentState store pv m, PVSupportsFlexibleCooldown pv) => + PersistentBlockState store pv -> -- | Timestamp for expiring cooldowns. Timestamp -> -- | Timestamp for pre-cooldowns entering cooldown. Timestamp -> - m (PersistentBlockState pv) + m (PersistentBlockState store pv) doProcessCooldowns pbs now newExpiry = do bsp <- loadPBS pbs (newAIC, newAccts) <- @@ -4270,10 +4331,10 @@ doProcessCooldowns pbs now newExpiry = do -- -- PRECONDITION: there are no pre-cooldowns. doProcessPrePreCooldowns :: - forall pv m. - (SupportsPersistentState pv m, PVSupportsFlexibleCooldown pv) => - PersistentBlockState pv -> - m (PersistentBlockState pv) + forall store pv m. + (SupportsPersistentState store pv m, PVSupportsFlexibleCooldown pv) => + PersistentBlockState store pv -> + m (PersistentBlockState store pv) doProcessPrePreCooldowns pbs = do bsp <- loadPBS pbs let oldAIC = bspAccountsInCooldown bsp ^. accountsInCooldown @@ -4293,16 +4354,16 @@ doProcessPrePreCooldowns pbs = do bspAccounts = newAccts } -doGetBankStatus :: (SupportsPersistentState pv m) => PersistentBlockState pv -> m Rewards.BankStatus +doGetBankStatus :: (SupportsPersistentState store pv m) => PersistentBlockState store pv -> m Rewards.BankStatus doGetBankStatus pbs = _unhashed . bspBank <$> loadPBS pbs -doSetRewardAccounts :: (SupportsPersistentState pv m) => PersistentBlockState pv -> Rewards.RewardAccounts -> m (PersistentBlockState pv) +doSetRewardAccounts :: (SupportsPersistentState store pv m) => PersistentBlockState store pv -> Rewards.RewardAccounts -> m (PersistentBlockState store pv) doSetRewardAccounts pbs rewards = do bsp <- loadPBS pbs storePBS pbs bsp{bspBank = bspBank bsp & unhashed . Rewards.rewardAccounts .~ rewards} -- | Get the index of accounts with scheduled releases. -doGetScheduledReleaseAccounts :: (SupportsPersistentState pv m) => PersistentBlockState pv -> m (Map.Map Timestamp (Set.Set AccountIndex)) +doGetScheduledReleaseAccounts :: (SupportsPersistentState store pv m) => PersistentBlockState store pv -> m (Map.Map Timestamp (Set.Set AccountIndex)) doGetScheduledReleaseAccounts pbs = do bsp <- loadPBS pbs let resolveAddress addr = do @@ -4314,9 +4375,9 @@ doGetScheduledReleaseAccounts pbs = do -- | Get the index of accounts with stake in cooldown. doGetCooldownAccounts :: - forall pv m. - (SupportsPersistentState pv m) => - PersistentBlockState pv -> + forall store pv m. + (SupportsPersistentState store pv m) => + PersistentBlockState store pv -> m (Map.Map Timestamp (Set.Set AccountIndex)) doGetCooldownAccounts pbs = case sSupportsFlexibleCooldown sav of STrue -> do @@ -4328,9 +4389,9 @@ doGetCooldownAccounts pbs = case sSupportsFlexibleCooldown sav of -- | Get the index of accounts in pre-cooldown. doGetPreCooldownAccounts :: - forall pv m. - (SupportsPersistentState pv m) => - PersistentBlockState pv -> + forall store pv m. + (SupportsPersistentState store pv m) => + PersistentBlockState store pv -> m [AccountIndex] doGetPreCooldownAccounts pbs = case sSupportsFlexibleCooldown sav of STrue -> do @@ -4342,9 +4403,9 @@ doGetPreCooldownAccounts pbs = case sSupportsFlexibleCooldown sav of -- | Get the index of accounts in pre-pre-cooldown. doGetPrePreCooldownAccounts :: - forall pv m. - (SupportsPersistentState pv m) => - PersistentBlockState pv -> + forall store pv m. + (SupportsPersistentState store pv m) => + PersistentBlockState store pv -> m [AccountIndex] doGetPrePreCooldownAccounts pbs = case sSupportsFlexibleCooldown sav of STrue -> do @@ -4360,12 +4421,12 @@ doGetPrePreCooldownAccounts pbs = case sSupportsFlexibleCooldown sav of -- -- PRECONDITION: The token identified by 'TokenIndex' MUST exist. doSetTokenCirculatingSupply :: - forall pv m. - (SupportsPersistentState pv m, PVSupportsPLT pv) => - PersistentBlockState pv -> + forall store pv m. + (SupportsPersistentState store pv m, PVSupportsPLT pv) => + PersistentBlockState store pv -> PLT.TokenIndex -> PLT.TokenRawAmount -> - m (PersistentBlockState pv) + m (PersistentBlockState store pv) doSetTokenCirculatingSupply pbs tokIx newSupply = do bsp <- loadPBS pbs newPLTs <- PLT.setTokenCirculatingSupply tokIx newSupply (bspProtocolLevelTokens bsp) @@ -4378,23 +4439,23 @@ doSetTokenCirculatingSupply pbs tokIx newSupply = do -- by a protocol-level token, i.e. @getTokenIndex s (_pltTokenId cfg)@ should return -- @Nothing@. doCreateToken :: - forall pv m. - (SupportsPersistentState pv m, PVSupportsPLT pv) => - PersistentBlockState pv -> + forall store pv m. + (SupportsPersistentState store pv m, PVSupportsPLT pv) => + PersistentBlockState store pv -> PLT.PLTConfiguration -> - m (PLT.TokenIndex, PersistentBlockState pv) + m (PLT.TokenIndex, PersistentBlockState store pv) doCreateToken pbs tokenConfig = do bsp <- loadPBS pbs (tokIx, newPLTs) <- PLT.createToken tokenConfig (bspProtocolLevelTokens bsp) (tokIx,) <$> storePBS pbs bsp{bspProtocolLevelTokens = newPLTs} doSetTokenState :: - forall pv m. - (SupportsPersistentState pv m, PVSupportsPLT pv) => - PersistentBlockState pv -> + forall store pv m. + (SupportsPersistentState store pv m, PVSupportsPLT pv) => + PersistentBlockState store pv -> PLT.TokenIndex -> - StateV1.MutableState -> - m (PersistentBlockState pv) + StateV1.MutableState store -> + m (PersistentBlockState store pv) doSetTokenState pbs tokenIndex mutableState = do bsp <- loadPBS pbs newPLTs <- PLT.setTokenState tokenIndex mutableState (bspProtocolLevelTokens bsp) @@ -4402,13 +4463,13 @@ doSetTokenState pbs tokenIndex mutableState = do -- | Update the token balance. doUpdateTokenAccountBalance :: - forall pv m. - (SupportsPersistentState pv m, PVSupportsPLT pv) => - PersistentBlockState pv -> + forall store pv m. + (SupportsPersistentState store pv m, PVSupportsPLT pv) => + PersistentBlockState store pv -> PLT.TokenIndex -> AccountIndex -> TokenAmountDelta -> - m (Maybe (PersistentBlockState pv)) + m (Maybe (PersistentBlockState store pv)) doUpdateTokenAccountBalance pbs tokIx accIx (TokenAmountDelta delta) = runMaybeT $ do bsp <- lift $ loadPBS pbs newAccounts <- Accounts.updateAccountsAtIndex' upd accIx (bspAccounts bsp) @@ -4433,12 +4494,12 @@ doUpdateTokenAccountBalance pbs tokIx accIx (TokenAmountDelta delta) = runMaybeT -- | Touch a token account, i.e. set the balance of the given token to zero if -- the account didn't have a balance before. doTouchTokenAccount :: - forall pv m. - (SupportsPersistentState pv m, PVSupportsPLT pv) => - PersistentBlockState pv -> + forall store pv m. + (SupportsPersistentState store pv m, PVSupportsPLT pv) => + PersistentBlockState store pv -> PLT.TokenIndex -> AccountIndex -> - m (Maybe (PersistentBlockState pv)) + m (Maybe (PersistentBlockState store pv)) doTouchTokenAccount pbs tokIx accIx = runMaybeT $ do bsp <- lift $ loadPBS pbs newAccounts <- Accounts.updateAccountsAtIndex' upd accIx (bspAccounts bsp) @@ -4453,38 +4514,43 @@ doTouchTokenAccount pbs tokIx accIx = runMaybeT $ do ) -- | Context that supports the persistent block state. -data PersistentBlockStateContext pv = PersistentBlockStateContext +data PersistentBlockStateContext store pv = PersistentBlockStateContext { -- | The 'BlobStore' used for storing the persistent state. - pbscBlobStore :: !BlobStore, + pbscBlobStore :: !(BlobStore store), -- | Cache used for caching accounts. - pbscAccountCache :: !(AccountCache (AccountVersionFor pv)), + pbscAccountCache :: !(AccountCache store (AccountVersionFor pv)), -- | Cache used for caching modules. - pbscModuleCache :: !Modules.ModuleCache, + pbscModuleCache :: !(Modules.ModuleCache store), -- | LMDB account map pbscAccountMap :: !LMDBAccountMap.DatabaseHandlers } -instance LMDBAccountMap.HasDatabaseHandlers (PersistentBlockStateContext pv) where +instance LMDBAccountMap.HasDatabaseHandlers (PersistentBlockStateContext store pv) where databaseHandlers = lens pbscAccountMap (\s v -> s{pbscAccountMap = v}) -instance HasBlobStore (PersistentBlockStateContext av) where +instance HasBlobStore store (PersistentBlockStateContext store av) where blobStore = bscBlobStore . pbscBlobStore blobLoadCallback = bscLoadCallback . pbscBlobStore blobStoreCallback = bscStoreCallback . pbscBlobStore -instance (AccountVersionFor pv ~ av) => Cache.HasCache (AccountCache av) (PersistentBlockStateContext pv) where +instance + (AccountVersionFor pv ~ av) => + Cache.HasCache (AccountCache store av) (PersistentBlockStateContext store pv) + where projectCache = pbscAccountCache -instance Cache.HasCache Modules.ModuleCache (PersistentBlockStateContext pv) where +instance Cache.HasCache (Modules.ModuleCache store) (PersistentBlockStateContext store pv) where projectCache = pbscModuleCache -instance (IsProtocolVersion pv) => MonadProtocolVersion (BlobStoreT (PersistentBlockStateContext pv) m) where - type MPV (BlobStoreT (PersistentBlockStateContext pv) m) = pv +instance (IsProtocolVersion pv) => MonadProtocolVersion (BlobStoreT store (PersistentBlockStateContext store pv) m) where + type MPV (BlobStoreT store (PersistentBlockStateContext store pv) m) = pv -- | 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 :: + (MonadIO m, MonadCatch.MonadMask m) => + Int -> FilePath -> BlobStoreT store (PersistentBlockStateContext store pv) m a -> BlobStoreT store (BlobStore store) m a withNewAccountCacheAndLMDBAccountMap size lmdbAccountMapDir bsm = MonadCatch.bracket openLmdbAccMap closeLmdbAccMap runAction where openLmdbAccMap = liftIO $ LMDBAccountMap.openDatabase lmdbAccountMapDir @@ -4496,58 +4562,69 @@ withNewAccountCacheAndLMDBAccountMap size lmdbAccountMapDir bsm = MonadCatch.bra 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} +newtype PersistentBlockStateMonad store (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, MonadCatch.MonadCatch, MonadCatch.MonadThrow) -type PersistentState av pv r m = +type PersistentState store av pv r m = ( MonadIO m, MonadReader r m, - HasBlobStore r, + HasBlobStore store r, AccountVersionFor pv ~ av, - Cache.HasCache (AccountCache av) r, - Cache.HasCache Modules.ModuleCache r, + Cache.HasCache (AccountCache store av) r, + Cache.HasCache (Modules.ModuleCache store) r, LMDBAccountMap.HasDatabaseHandlers r, MonadLogger m ) -instance MonadTrans (PersistentBlockStateMonad pv r) where +instance MonadTrans (PersistentBlockStateMonad store pv r) where lift = PersistentBlockStateMonad -instance (PersistentState av pv r m) => MonadBlobStore (PersistentBlockStateMonad pv r m) -instance (PersistentState av pv r m) => MonadBlobStore (PutT (PersistentBlockStateMonad pv r m)) -instance (PersistentState av pv r m) => MonadBlobStore (PutH (PersistentBlockStateMonad pv r m)) +type instance MBSStore (PersistentBlockStateMonad store pv r m) = store +instance (PersistentState store av pv r m) => MonadBlobStore (PersistentBlockStateMonad store pv r m) +type instance MBSStore (PutT (PersistentBlockStateMonad store pv r m)) = store -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 store av pv r m) => MonadBlobStore (PutT (PersistentBlockStateMonad store pv r m)) +type instance MBSStore (PutH (PersistentBlockStateMonad store pv r m)) = store +instance (PersistentState store av pv r m) => MonadBlobStore (PutH (PersistentBlockStateMonad store pv r m)) -deriving via (LMDBAccountMap.AccountMapStoreMonad m) instance (MonadIO m, MonadLogger m, MonadReader r m, LMDBAccountMap.HasDatabaseHandlers r) => LMDBAccountMap.MonadAccountMapStore (PersistentBlockStateMonad pv r m) -deriving via (LMDBAccountMap.AccountMapStoreMonad m) instance (MonadIO m, MonadLogger m, MonadReader r m, LMDBAccountMap.HasDatabaseHandlers r) => MonadModuleMapStore (PersistentBlockStateMonad pv r m) +instance + (PersistentState store av pv r m) => + Cache.MonadCache (AccountCache store av) (PersistentBlockStateMonad store pv r m) +instance + (PersistentState store av pv r m) => + Cache.MonadCache (Modules.ModuleCache store) (PersistentBlockStateMonad store pv r m) + +deriving via (LMDBAccountMap.AccountMapStoreMonad m) instance (MonadIO m, MonadLogger m, MonadReader r m, LMDBAccountMap.HasDatabaseHandlers r) => LMDBAccountMap.MonadAccountMapStore (PersistentBlockStateMonad store pv r m) +deriving via (LMDBAccountMap.AccountMapStoreMonad m) instance (MonadIO m, MonadLogger m, MonadReader r m, LMDBAccountMap.HasDatabaseHandlers r) => MonadModuleMapStore (PersistentBlockStateMonad store pv r m) -type instance BlockStatePointer (PersistentBlockState pv) = BlobRef (BlockStatePointers pv) -type instance BlockStatePointer (HashedPersistentBlockState pv) = BlobRef (BlockStatePointers pv) +type instance BlockStatePointer (PersistentBlockState store pv) = BlobRef store (BlockStatePointers store pv) +type instance BlockStatePointer (HashedPersistentBlockState store pv) = BlobRef store (BlockStatePointers store pv) -instance (IsProtocolVersion pv) => MonadProtocolVersion (PersistentBlockStateMonad pv r m) where - type MPV (PersistentBlockStateMonad pv r m) = pv +instance (IsProtocolVersion pv) => MonadProtocolVersion (PersistentBlockStateMonad store pv r m) where + type MPV (PersistentBlockStateMonad store pv r m) = pv -instance BlockStateTypes (PersistentBlockStateMonad pv r m) where - type BlockState (PersistentBlockStateMonad pv r m) = HashedPersistentBlockState pv - type UpdatableBlockState (PersistentBlockStateMonad pv r m) = PersistentBlockState pv - type Account (PersistentBlockStateMonad pv r m) = PersistentAccount (AccountVersionFor pv) - type BakerInfoRef (PersistentBlockStateMonad pv r m) = PersistentBakerInfoRef (AccountVersionFor pv) - type ContractState (PersistentBlockStateMonad pv r m) = Instances.InstanceStateV - type InstrumentedModuleRef (PersistentBlockStateMonad pv r m) = Modules.PersistentInstrumentedModuleV - type MutableTokenState (PersistentBlockStateMonad pv r m) = StateV1.MutableState +instance BlockStateTypes (PersistentBlockStateMonad store pv r m) where + type BlockState (PersistentBlockStateMonad store pv r m) = HashedPersistentBlockState store pv + type UpdatableBlockState (PersistentBlockStateMonad store pv r m) = PersistentBlockState store pv + type Account (PersistentBlockStateMonad store pv r m) = PersistentAccount store (AccountVersionFor pv) + type BakerInfoRef (PersistentBlockStateMonad store pv r m) = PersistentBakerInfoRef store (AccountVersionFor pv) + type ContractState (PersistentBlockStateMonad store pv r m) = Instances.InstanceStateV store + type InstrumentedModuleRef (PersistentBlockStateMonad store pv r m) = Modules.PersistentInstrumentedModuleV store + type MutableTokenState (PersistentBlockStateMonad store pv r m) = StateV1.MutableState store -instance (PersistentState av pv r m) => ModuleQuery (PersistentBlockStateMonad pv r m) where +instance (PersistentState store av pv r m) => ModuleQuery (PersistentBlockStateMonad store pv r m) where getModuleArtifact = doGetModuleArtifact -instance (PersistentState av pv r m) => TokenStateOperations StateV1.MutableState (PersistentBlockStateMonad pv r m) where +instance + (PersistentState store av pv r m) => + TokenStateOperations (StateV1.MutableState store) (PersistentBlockStateMonad store pv r m) + where lookupTokenState = PLT.lookupTokenState updateTokenState = PLT.updateTokenState instance - (IsProtocolVersion pv, PersistentState av pv r m) => - PLTQuery (PersistentBlockState pv) StateV1.MutableState (PersistentBlockStateMonad pv r m) + (IsProtocolVersion pv, PersistentState store av pv r m) => + PLTQuery (PersistentBlockState store pv) (StateV1.MutableState store) (PersistentBlockStateMonad store pv r m) where getPLTList = PLT.getPLTList . bspProtocolLevelTokens <=< loadPBS @@ -4561,8 +4638,8 @@ instance PLT.getTokenCirculatingSupply tokIx . bspProtocolLevelTokens =<< loadPBS bs instance - (IsProtocolVersion pv, PersistentState av pv r m) => - PLTQuery (HashedPersistentBlockState pv) StateV1.MutableState (PersistentBlockStateMonad pv r m) + (IsProtocolVersion pv, PersistentState store av pv r m) => + PLTQuery (HashedPersistentBlockState store pv) (StateV1.MutableState store) (PersistentBlockStateMonad store pv r m) where getPLTList = getPLTList . hpbsPointers getTokenIndex = getTokenIndex . hpbsPointers @@ -4570,7 +4647,7 @@ instance getTokenConfiguration = getTokenConfiguration . hpbsPointers getTokenCirculatingSupply = getTokenCirculatingSupply . hpbsPointers -instance (IsProtocolVersion pv, PersistentState av pv r m) => BlockStateQuery (PersistentBlockStateMonad pv r m) where +instance (IsProtocolVersion pv, PersistentState store av pv r m) => BlockStateQuery (PersistentBlockStateMonad store pv r m) where getModule = doGetModuleSource . hpbsPointers getModuleInterface pbs mref = doGetModule (hpbsPointers pbs) mref getAccount = doGetAccount . hpbsPointers @@ -4622,7 +4699,7 @@ instance (IsProtocolVersion pv, PersistentState av pv r m) => BlockStateQuery (P getPreCooldownAccounts = doGetPreCooldownAccounts . hpbsPointers getPrePreCooldownAccounts = doGetPrePreCooldownAccounts . hpbsPointers -instance (MonadIO m, PersistentState av pv r m) => ContractStateOperations (PersistentBlockStateMonad pv r m) where +instance (MonadIO m, PersistentState store av pv r m) => ContractStateOperations (PersistentBlockStateMonad store pv r m) where thawContractState (Instances.InstanceStateV0 inst) = return inst thawContractState (Instances.InstanceStateV1 inst) = liftIO . flip StateV1.thaw inst . fst =<< getCallbacks externalContractState (Instances.InstanceStateV0 inst) = return inst @@ -4636,7 +4713,7 @@ instance (MonadIO m, PersistentState av pv r m) => ContractStateOperations (Pers {-# INLINE getV1StateContext #-} {-# INLINE contractStateToByteString #-} -instance (PersistentState av pv r m, IsProtocolVersion pv) => AccountOperations (PersistentBlockStateMonad pv r m) where +instance (PersistentState store av pv r m, IsProtocolVersion pv) => AccountOperations (PersistentBlockStateMonad store pv r m) where getAccountCanonicalAddress = accountCanonicalAddress getAccountAmount = accountAmount @@ -4678,7 +4755,7 @@ instance (PersistentState av pv r m, IsProtocolVersion pv) => AccountOperations getAccountTokens = accountTokens getAccountTokenBalance = accountTokenBalance -instance (IsProtocolVersion pv, PersistentState av pv r m) => BlockStateOperations (PersistentBlockStateMonad pv r m) where +instance (IsProtocolVersion pv, PersistentState store av pv r m) => BlockStateOperations (PersistentBlockStateMonad store pv r m) where bsoGetModule pbs mref = doGetModule pbs mref bsoGetAccount bs = doGetAccount bs bsoGetAccountIndex = doGetAccountIndex @@ -4768,11 +4845,11 @@ instance (IsProtocolVersion pv, PersistentState av pv r m) => BlockStateOperatio bsoSetTokenState = doSetTokenState bsoUpdateTokenAccountBalance = doUpdateTokenAccountBalance bsoTouchTokenAccount = doTouchTokenAccount - type StateSnapshot (PersistentBlockStateMonad pv r m) = BlockStatePointers pv + type StateSnapshot (PersistentBlockStateMonad store pv r m) = BlockStatePointers store pv bsoSnapshotState = loadPBS bsoRollback = storePBS -instance (IsProtocolVersion pv, PersistentState av pv r m) => BlockStateStorage (PersistentBlockStateMonad pv r m) where +instance (IsProtocolVersion pv, PersistentState store av pv r m) => BlockStateStorage (PersistentBlockStateMonad store pv r m) where thawBlockState = doThawBlockState freezeBlockState = hashBlockState @@ -4825,8 +4902,8 @@ instance (IsProtocolVersion pv, PersistentState av pv r m) => BlockStateStorage {-# INLINE blockStateLoadCallback #-} collapseCaches = do - Cache.collapseCache (Proxy :: Proxy (AccountCache av)) - Cache.collapseCache (Proxy :: Proxy Modules.ModuleCache) + Cache.collapseCache (Proxy :: Proxy (AccountCache store av)) + Cache.collapseCache (Proxy :: Proxy (Modules.ModuleCache store)) cacheBlockState = cacheState @@ -4859,8 +4936,8 @@ migratePersistentBlockState :: forall oldpv pv t m. ( MonadTrans t, MonadBlobStore (t m), - SupportsPersistentAccount oldpv m, - SupportsPersistentAccount pv (t m), + SupportsPersistentAccount (MBSStore m) oldpv m, + SupportsPersistentAccount (MBSStore (t m)) pv (t m), Modules.SupportsPersistentModule m, Modules.SupportsPersistentModule (t m), MonadProtocolVersion (t m), @@ -4869,8 +4946,8 @@ migratePersistentBlockState :: MPV m ~ oldpv ) => StateMigrationParameters oldpv pv -> - PersistentBlockState oldpv -> - t m (PersistentBlockState pv) + PersistentBlockState (MBSStore m) oldpv -> + t m (PersistentBlockState (MBSStore (t m)) pv) migratePersistentBlockState migration oldState = do !newState <- migrateBlockPointers migration =<< lift . refLoad =<< liftIO (readIORef oldState) newStateRef <- refMake newState @@ -4878,20 +4955,20 @@ migratePersistentBlockState migration oldState = do liftIO . newIORef $! newStateRefFlushed migrateBlockPointers :: - forall oldpv pv t m. + forall oldstore store oldpv pv t m. ( SupportMigration m t, MonadProtocolVersion m, MPV m ~ oldpv, MonadProtocolVersion (t m), MPV (t m) ~ pv, - SupportsPersistentAccount oldpv m, - SupportsPersistentAccount pv (t m), + SupportsPersistentAccount oldstore oldpv m, + SupportsPersistentAccount store pv (t m), Modules.SupportsPersistentModule m, Modules.SupportsPersistentModule (t m) ) => StateMigrationParameters oldpv pv -> - BlockStatePointers oldpv -> - t m (BlockStatePointers pv) + BlockStatePointers oldstore oldpv -> + t m (BlockStatePointers store pv) migrateBlockPointers migration BlockStatePointers{..} = do -- We migrate the release schedule first because we may need to access the -- accounts in the process. @@ -4913,7 +4990,7 @@ migrateBlockPointers migration BlockStatePointers{..} = do newReleaseSchedule <- migrateReleaseSchedule rsMigration bspReleaseSchedule pab <- lift . refLoad $ bspBirkParameters ^. birkActiveBakers -- When we migrate the accounts, we accumulate state - initMigrationState :: MigrationState.AccountMigrationState oldpv pv <- + initMigrationState :: MigrationState.AccountMigrationState store oldpv pv <- MigrationState.makeInitialAccountMigrationState bspAccounts pab logEvent GlobalState LLTrace "Migrating accounts" (newAccounts, migrationState) <- @@ -4987,9 +5064,9 @@ migrateBlockPointers migration BlockStatePointers{..} = do -- a pointer to the parent difference maps. The parent difference map is empty if the parent is -- finalized, otherwise it may contain new accounts created in that block. doThawBlockState :: - (SupportsPersistentState pv m) => - HashedPersistentBlockState pv -> - m (PersistentBlockState pv) + (SupportsPersistentState store pv m) => + HashedPersistentBlockState store pv -> + m (PersistentBlockState store pv) doThawBlockState HashedPersistentBlockState{..} = do bsp@BlockStatePointers{..} <- loadPBS hpbsPointers bspAccounts' <- Accounts.mkNewChildDifferenceMap bspAccounts @@ -5002,13 +5079,13 @@ doThawBlockState HashedPersistentBlockState{..} = do -- | Cache the block state. cacheState :: - forall pv m. - (SupportsPersistentState pv m) => - HashedPersistentBlockState pv -> + forall store pv m. + (SupportsPersistentState store pv m) => + HashedPersistentBlockState store pv -> m () cacheState hpbs = do BlockStatePointers{..} <- loadPBS (hpbsPointers hpbs) - accts <- liftCache (return @_ @(PersistentAccount (AccountVersionFor pv))) bspAccounts + accts <- liftCache (return @_ @(PersistentAccount store (AccountVersionFor pv))) bspAccounts -- first cache the modules mods <- cache bspModules -- then cache the instances, but don't cache the modules again. Instead @@ -5047,9 +5124,9 @@ cacheState hpbs = do -- | Cache the block state and get the initial (empty) transaction table with the next -- update sequence numbers populated. cacheStateAndGetTransactionTable :: - forall pv m. - (SupportsPersistentState pv m) => - HashedPersistentBlockState pv -> + forall store pv m. + (SupportsPersistentState store pv m) => + HashedPersistentBlockState store pv -> m TransactionTable.TransactionTable cacheStateAndGetTransactionTable hpbs = do BlockStatePointers{..} <- loadPBS (hpbsPointers hpbs) diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState/Modules.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState/Modules.hs index bea304ccdd..4000dc8be2 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState/Modules.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState/Modules.hs @@ -68,7 +68,7 @@ import Lens.Micro.Platform -- | An @InstrumentedModuleV v@ in the @PersistentBlockState@, where -- @v@ is the @WasmVersion@. -data PersistentInstrumentedModuleV (v :: WasmVersion) +data PersistentInstrumentedModuleV store (v :: WasmVersion) = -- | The instrumented module is retained in memory only. -- This is the case before finalization. PIMVMem !(GSWasm.InstrumentedModuleV v) @@ -76,18 +76,21 @@ data PersistentInstrumentedModuleV (v :: WasmVersion) -- bytes can be read from the blob store via the @BlobPtr@. -- The @BlobPtr@ is used to reconstruct artifact on the Rust side, copying it as needed -- from the blob store. - PIMVPtr !(BlobPtr (GSWasm.InstrumentedModuleV v)) + PIMVPtr !(BlobPtr store (GSWasm.InstrumentedModuleV v)) deriving (Show) -- | Make a 'PersistentInstrumentedModuleV' from a 'GSWasm.InstrumentedModuleV', retaining it in -- memory only. -makePersistentInstrumentedModuleV :: GSWasm.InstrumentedModuleV v -> PersistentInstrumentedModuleV v +makePersistentInstrumentedModuleV :: GSWasm.InstrumentedModuleV v -> PersistentInstrumentedModuleV store v makePersistentInstrumentedModuleV = PIMVMem -- | Load a 'PersistentInstrumentedModuleV', retrieving the artifact. -- If the artifact has been persisted to the blob store, the artifact will wrap a pointer into -- the memory-mapped blob store. -loadInstrumentedModuleV :: forall m v. (MonadBlobStore m, IsWasmVersion v) => PersistentInstrumentedModuleV v -> m (GSWasm.InstrumentedModuleV v) +loadInstrumentedModuleV :: + forall m v. + (MonadBlobStore m, IsWasmVersion v) => + PersistentInstrumentedModuleV (MBSStore m) v -> m (GSWasm.InstrumentedModuleV v) loadInstrumentedModuleV (PIMVMem im) = return im loadInstrumentedModuleV (PIMVPtr ptr) = do bs <- loadBlobPtr ptr @@ -96,67 +99,74 @@ loadInstrumentedModuleV (PIMVPtr ptr) = do -- | A module contains both the module interface and the raw source code of the -- module. The module is parameterized by the wasm version, which determines the shape -- of the module interface. -data ModuleV v = ModuleV +data ModuleV store (v :: WasmVersion) = ModuleV { -- | The instrumented module, ready to be instantiated. - moduleVInterface :: !(GSWasm.ModuleInterfaceA (PersistentInstrumentedModuleV v)), + moduleVInterface :: !(GSWasm.ModuleInterfaceA (PersistentInstrumentedModuleV store v)), -- | A plain reference to the raw module binary source. This is generally not needed by consensus, so -- it is almost always simply kept on disk. - moduleVSource :: !(BlobRef (WasmModuleV v)) + moduleVSource :: !(BlobRef store (WasmModuleV v)) } deriving (Show) -- | Helper to convert from an interface to a module. -toModule :: forall v. (IsWasmVersion v) => GSWasm.ModuleInterfaceV v -> BlobRef (WasmModuleV v) -> Module +toModule :: + forall store v. + (IsWasmVersion v) => + GSWasm.ModuleInterfaceV v -> BlobRef store (WasmModuleV v) -> Module store toModule mvi moduleVSource = case getWasmVersion @v of SV0 -> ModuleV0 ModuleV{..} SV1 -> ModuleV1 ModuleV{..} where + moduleVInterface :: GSWasm.ModuleInterfaceA (PersistentInstrumentedModuleV store v) moduleVInterface = PIMVMem <$> mvi -- | A module, either of version 0 or 1. This is only used when storing a module -- independently, e.g., in the module table. When a module is referenced from a -- contract instance we use the ModuleV type directly so we may tie the version -- of the module to the version of the instance. -data Module where - ModuleV0 :: !(ModuleV GSWasm.V0) -> Module - ModuleV1 :: !(ModuleV GSWasm.V1) -> Module +data Module store where + ModuleV0 :: !(ModuleV store GSWasm.V0) -> Module store + ModuleV1 :: !(ModuleV store GSWasm.V1) -> Module store deriving (Show) -getModuleInterface :: Module -> GSWasm.ModuleInterface PersistentInstrumentedModuleV +getModuleInterface :: Module store -> GSWasm.ModuleInterface (PersistentInstrumentedModuleV store) getModuleInterface (ModuleV0 m) = GSWasm.ModuleInterfaceV0 (moduleVInterface m) getModuleInterface (ModuleV1 m) = GSWasm.ModuleInterfaceV1 (moduleVInterface m) -- | Coerce a module to V0. Will fail if the version is not 'V0'. -unsafeToModuleV0 :: Module -> ModuleV V0 +unsafeToModuleV0 :: Module store -> ModuleV store V0 unsafeToModuleV0 (ModuleV0 m) = m unsafeToModuleV0 (ModuleV1 _) = error "Could not coerce module to V0." -- | Coerce a module to V1. Will fail if the version is not 'V1'. -unsafeToModuleV1 :: Module -> ModuleV V1 +unsafeToModuleV1 :: Module store -> ModuleV store V1 unsafeToModuleV1 (ModuleV0 _) = error "Could not coerce module to V1." unsafeToModuleV1 (ModuleV1 m) = m -- | Coerce a 'Module' to a 'ModuleV' depending on the 'WasmVersion'. -- This results in an error if the module is not of the desired version. -unsafeToModuleV :: forall v. (IsWasmVersion v) => Module -> ModuleV v +unsafeToModuleV :: forall store v. (IsWasmVersion v) => Module store -> ModuleV store v unsafeToModuleV = case getWasmVersion @v of SV0 -> unsafeToModuleV0 SV1 -> unsafeToModuleV1 -instance GSWasm.HasModuleRef Module where +instance GSWasm.HasModuleRef (Module store) where moduleReference (ModuleV0 m) = GSWasm.moduleReference (moduleVInterface m) moduleReference (ModuleV1 m) = GSWasm.moduleReference (moduleVInterface m) -- The module reference already takes versioning into account, so this instance is reasonable. -instance HashableTo Hash Module where +instance HashableTo Hash (Module store) where getHash = coerce . GSWasm.moduleReference -instance (Monad m) => MHashableTo m Hash Module -instance (MonadBlobStore m) => Cacheable m Module +instance (Monad m) => MHashableTo m Hash (Module store) +instance (MonadBlobStore m) => Cacheable m (Module store) -- | Load a module from the underlying storage, without recompiling the artifact. -loadModuleDirect :: (MonadLogger m, MonadBlobStore m) => BlobRef Module -> m Module +loadModuleDirect :: + forall m. + (MonadLogger m, MonadBlobStore m) => + BlobRef (MBSStore m) (Module (MBSStore m)) -> m (Module (MBSStore m)) loadModuleDirect br = do bs <- loadRaw br let getModule = do @@ -175,7 +185,7 @@ loadModuleDirect br = do skip (fromIntegral artLen) -- Footer miModuleSize <- getWord64be - let miModule :: PersistentInstrumentedModuleV v + let miModule :: PersistentInstrumentedModuleV (MBSStore m) v miModule = PIMVPtr BlobPtr @@ -190,7 +200,8 @@ loadModuleDirect br = do - startOffset, blobPtrLen = fromIntegral artLen } - moduleVInterface :: GSWasm.ModuleInterfaceA (PersistentInstrumentedModuleV v) + moduleVInterface :: + GSWasm.ModuleInterfaceA (PersistentInstrumentedModuleV (MBSStore m) v) moduleVInterface = GSWasm.ModuleInterface{..} case artVersion of V0 -> do @@ -205,7 +216,10 @@ loadModuleDirect br = do -- | This instance is based on and should be compatible with the 'Serialize' instance -- for 'BasicModuleInterface'. -instance (MonadLogger m, MonadBlobStore m, MonadProtocolVersion m) => DirectBlobStorable m Module where +instance + (MonadLogger m, MonadBlobStore m, MonadProtocolVersion m, store ~ MBSStore m) => + DirectBlobStorable m (Module store) + where loadDirect br | potentialLegacyArtifacts = do mv <- loadModuleDirect br @@ -244,7 +258,10 @@ instance (MonadLogger m, MonadBlobStore m, MonadProtocolVersion m) => DirectBlob ModuleV0 mv0 -> sudV SV0 mv0 ModuleV1 mv1 -> sudV SV1 mv1 where - sudV :: SWasmVersion v -> ModuleV v -> m (BlobRef Module, Module) + sudV :: + SWasmVersion v -> + ModuleV (MBSStore m) v -> + m (BlobRef (MBSStore m) (Module (MBSStore m)), Module (MBSStore m)) sudV ver ModuleV{moduleVInterface = GSWasm.ModuleInterface{..}, ..} = do !instrumentedModuleBytes <- case miModule of PIMVMem instrModule -> return $ case ver of @@ -279,11 +296,11 @@ instance (MonadLogger m, MonadBlobStore m, MonadProtocolVersion m) => DirectBlob } let mv' = ModuleV{moduleVInterface = GSWasm.ModuleInterface{miModule = miModule', ..}, ..} return $!! (br, mkModule ver mv') - mkModule :: SWasmVersion v -> ModuleV v -> Module + mkModule :: SWasmVersion v -> ModuleV (MBSStore m) v -> Module (MBSStore m) mkModule SV0 = ModuleV0 mkModule SV1 = ModuleV1 -instance (MonadBlobStore m) => DirectBlobHashable m Hash Module where +instance (MonadBlobStore m) => DirectBlobHashable m Hash (Module store) where loadHash br = do bs <- loadRaw br -- Decode the module reference only. @@ -300,13 +317,13 @@ instance (MonadBlobStore m) => DirectBlobHashable m Hash Module where -- -- The module is cached in the 'ModuleCache' while the actual artifact is -- loaded on demand. -type CachedModule = HashedCachedRef ModuleCache Module +type CachedModule store = HashedCachedRef store (ModuleCache store) (Module store) -- | The cache retaining 'Module's -type ModuleCache = FIFOCache Module +type ModuleCache store = FIFOCache store (Module store) -- | Construct a new `ModuleCache` with the given size. -newModuleCache :: Int -> IO ModuleCache +newModuleCache :: Int -> IO (ModuleCache store) newModuleCache = newCache -- | Make sure that a monad supports the `MonadBlobStore` and `MonadCache` @@ -314,19 +331,19 @@ newModuleCache = newCache type SupportsPersistentModule m = ( MonadLogger m, MonadBlobStore m, - MonadCache ModuleCache m, + MonadCache (ModuleCache (MBSStore m)) m, MonadModuleMapStore m ) -- | The collection of modules stored in a block state. -data Modules = Modules +data Modules store = Modules { -- | A tree of 'Module's indexed by 'ModuleIndex' -- The modules themselves are cached `HashedCachedRef` hence only a limited -- amount of modules may be retained in memory at the same time. -- Modules themselves are wrapped in a @DirectBufferedRef@ which -- serves the purpose of not loading the artifact before it is required -- by the rust wasm execution engine. - _modulesTable :: !(LFMBTree' ModuleIndex HashedBufferedRef CachedModule), + _modulesTable :: !(LFMBTree' ModuleIndex (HashedBufferedRef store) (CachedModule store)), -- | Reference to the difference map that maps module references to module indices for -- modules added since the last finalized block. _modulesDifferenceMap :: !ModuleDifferenceMapReference @@ -335,13 +352,23 @@ data Modules = Modules makeLenses ''Modules -- | The hash of the collection of modules is the hash of the tree. -instance (MonadProtocolVersion m, SupportsPersistentModule m, IsBlockHashVersion (BlockHashVersionFor pv)) => MHashableTo m (ModulesHash pv) Modules where +instance + ( MonadProtocolVersion m, + SupportsPersistentModule m, + IsBlockHashVersion (BlockHashVersionFor pv), + store ~ MBSStore m + ) => + MHashableTo m (ModulesHash pv) (Modules store) + where getHashM = fmap (ModulesHash . LFMB.theLFMBTreeHash @(BlockHashVersionFor pv)) . getHashM . _modulesTable -instance (MonadProtocolVersion m, SupportsPersistentModule m) => BlobStorable m Modules where +instance + (MonadProtocolVersion m, SupportsPersistentModule m, store ~ MBSStore m) => + BlobStorable m (Modules store) + where load = do table <- load return $ do @@ -352,7 +379,10 @@ instance (MonadProtocolVersion m, SupportsPersistentModule m) => BlobStorable m (pModulesTable, _modulesTable') <- storeUpdate _modulesTable return (pModulesTable, m{_modulesTable = _modulesTable'}) -instance (MonadProtocolVersion m, SupportsPersistentModule m) => Cacheable m Modules where +instance + (MonadProtocolVersion m, SupportsPersistentModule m, store ~ MBSStore m) => + Cacheable m (Modules store) + where cache Modules{..} = do modulesTable' <- cache _modulesTable return Modules{_modulesTable = modulesTable', ..} @@ -360,12 +390,12 @@ instance (MonadProtocolVersion m, SupportsPersistentModule m) => Cacheable m Mod -------------------------------------------------------------------------------- -- | The empty collection of modules -emptyModules :: (MonadIO m) => m Modules +emptyModules :: (MonadIO m) => m (Modules store) emptyModules = Modules LFMB.empty <$> DiffMap.newEmptyReference -- | Get the 'ModuleIndex' for a module reference. This first consults the difference map, -- and then the LMDB map if the module is not in the difference map. -getModuleIndex :: (SupportsPersistentModule m) => ModuleRef -> Modules -> m (Maybe ModuleIndex) +getModuleIndex :: (SupportsPersistentModule m) => ModuleRef -> Modules (MBSStore m) -> m (Maybe ModuleIndex) getModuleIndex ref mods = do -- First, look up in the difference map DiffMap.refLookup ref (mods ^. modulesDifferenceMap) >>= \case @@ -384,8 +414,8 @@ getModuleIndex ref mods = do putInterface :: (MonadProtocolVersion m, IsWasmVersion v, SupportsPersistentModule m) => (GSWasm.ModuleInterfaceV v, WasmModuleV v) -> - Modules -> - m (Maybe Modules) + Modules (MBSStore m) -> + m (Maybe (Modules (MBSStore m))) putInterface (modul, src) m = getModuleIndex mref m >>= \case Just _ -> return Nothing @@ -397,7 +427,9 @@ putInterface (modul, src) m = where mref = GSWasm.moduleReference modul -getModule :: (MonadProtocolVersion m, SupportsPersistentModule m) => ModuleRef -> Modules -> m (Maybe Module) +getModule :: + (MonadProtocolVersion m, SupportsPersistentModule m) => + ModuleRef -> Modules (MBSStore m) -> m (Maybe (Module (MBSStore m))) getModule ref mods = getModuleIndex ref mods >>= \case Nothing -> return Nothing @@ -406,7 +438,9 @@ getModule ref mods = -- | Gets the 'HashedCachedRef' to a module as stored in the module table -- to be given to instances when associating them with the interface. -- The reason we return the reference here is to allow for sharing of the reference. -getModuleReference :: (MonadProtocolVersion m, SupportsPersistentModule m) => ModuleRef -> Modules -> m (Maybe CachedModule) +getModuleReference :: + (MonadProtocolVersion m, SupportsPersistentModule m) => + ModuleRef -> Modules (MBSStore m) -> m (Maybe (CachedModule (MBSStore m))) getModuleReference ref mods = getModuleIndex ref mods >>= \case Nothing -> return Nothing @@ -416,13 +450,15 @@ getModuleReference ref mods = getInterface :: (MonadProtocolVersion m, SupportsPersistentModule m) => ModuleRef -> - Modules -> - m (Maybe (GSWasm.ModuleInterface PersistentInstrumentedModuleV)) + Modules (MBSStore m) -> + m (Maybe (GSWasm.ModuleInterface (PersistentInstrumentedModuleV (MBSStore m)))) getInterface ref mods = fmap getModuleInterface <$> getModule ref mods -- | Get the source of a module by module reference. -- This does not cache the module. -getSource :: (MonadProtocolVersion m, SupportsPersistentModule m) => ModuleRef -> Modules -> m (Maybe WasmModule) +getSource :: + (MonadProtocolVersion m, SupportsPersistentModule m) => + ModuleRef -> Modules (MBSStore m) -> m (Maybe WasmModule) getSource ref mods = do mRef <- getModuleReference ref mods case mRef of @@ -442,18 +478,20 @@ getSource ref mods = do -- | Get the list of all currently deployed modules. -- The order of the list is not specified. -moduleRefList :: (MonadProtocolVersion m, SupportsPersistentModule m) => Modules -> m [ModuleRef] +moduleRefList :: + (MonadProtocolVersion m, SupportsPersistentModule m) => + Modules (MBSStore m) -> m [ModuleRef] moduleRefList mods = LFMB.mfoldRef (\l m -> (: l) . ModuleRef <$> getHashM m) [] (mods ^. modulesTable) -- | Get the size of the module table. -moduleCount :: Modules -> Word64 +moduleCount :: Modules store -> Word64 moduleCount = LFMB.size . _modulesTable -- | Initialize the LMDB-backed module map if it is not already initialized. -- If the module map contains fewer modules than the module table, it is wiped and repopulated -- with the modules in the table. Otherwise, the module map is left unchanged. -tryPopulateModuleLMDB :: (MonadProtocolVersion m, SupportsPersistentModule m) => Modules -> m () +tryPopulateModuleLMDB :: (MonadProtocolVersion m, SupportsPersistentModule m) => Modules (MBSStore m) -> m () tryPopulateModuleLMDB mods = do lmdbModuleCount <- getNumberOfModules let tableSize = LFMB.size (mods ^. modulesTable) @@ -475,7 +513,7 @@ tryPopulateModuleLMDB mods = do -- This is done by traversing the difference map and inserting the new modules into the module map. -- The difference map is then cleared. -- This function MUST be called whenever a block is finalized. -writeModulesAdded :: (SupportsPersistentModule m) => Modules -> m () +writeModulesAdded :: (SupportsPersistentModule m) => Modules (MBSStore m) -> m () writeModulesAdded mods = do mModulesAdded <- liftIO $ readIORef $ mods ^. modulesDifferenceMap forM_ mModulesAdded $ \diffMap -> do @@ -488,7 +526,7 @@ writeModulesAdded mods = do -- | Create a new 'Modules' object that is a child of the given 'Modules'. -- The new 'Modules' object will have the same modules as the parent, but with a new -- difference map that is the child of the parent's difference map. -mkNewChild :: (SupportsPersistentModule m) => Modules -> m Modules +mkNewChild :: (SupportsPersistentModule m) => Modules (MBSStore m) -> m (Modules (MBSStore m)) mkNewChild = modulesDifferenceMap DiffMap.newChildReference -- | Reconstruct the difference map from the modules table. @@ -500,7 +538,7 @@ reconstructDifferenceMap :: (MonadProtocolVersion m, SupportsPersistentModule m) => -- | The difference map reference and module table size from the parent block. (ModuleDifferenceMapReference, Word64) -> - Modules -> + Modules (MBSStore m) -> -- | The (updated) difference map reference and the module table size of this block. m (ModuleDifferenceMapReference, Word64) reconstructDifferenceMap (parentDiffMap, parentModulesCount) Modules{..} = do @@ -510,7 +548,7 @@ reconstructDifferenceMap (parentDiffMap, parentModulesCount) Modules{..} = do LFMB.traverseWhileDescRef trav _modulesTable return (_modulesDifferenceMap, LFMB.size _modulesTable) where - trav :: ModuleIndex -> CachedModule -> m Bool + trav :: ModuleIndex -> CachedModule (MBSStore m) -> m Bool trav midx theMod | midx < parentModulesCount = return False | otherwise = do @@ -530,8 +568,8 @@ migrateModules :: SupportMigration m t ) => StateMigrationParameters (MPV m) (MPV (t m)) -> - Modules -> - t m Modules + Modules (MBSStore m) -> + t m (Modules (MBSStore (t m))) migrateModules migration mods = do newModulesTable <- LFMB.migrateLFMBTree migrateCachedModule (_modulesTable mods) return @@ -540,14 +578,17 @@ migrateModules migration mods = do _modulesTable = newModulesTable } where - migrateCachedModule :: CachedModule -> t m CachedModule + migrateCachedModule :: CachedModule (MBSStore m) -> t m (CachedModule (MBSStore (t m))) migrateCachedModule cm = do existingModule <- lift (refLoad cm) case existingModule of ModuleV0 v0 -> migrateModuleV v0 ModuleV1 v1 -> migrateModuleV v1 - migrateModuleV :: forall v. (IsWasmVersion v) => ModuleV v -> t m CachedModule + migrateModuleV :: + forall v. + (IsWasmVersion v) => + ModuleV (MBSStore m) v -> t m (CachedModule (MBSStore (t m))) migrateModuleV ModuleV{..} = do (newModuleVSource, wasmMod) <- do -- Load the module source from the old context. @@ -587,13 +628,18 @@ migrateModules migration mods = do moduleVSource = newModuleVSource } - mkModule :: SWasmVersion v -> ModuleV v -> Module + mkModule :: SWasmVersion v -> ModuleV store v -> Module store mkModule SV0 = ModuleV0 mkModule SV1 = ModuleV1 -- Recompile a wasm module from the given source for protocols 1-6. -- This does not change the semantics, but does convert the artifact into the new format. - recompileArtifact :: forall v iface. (IsWasmVersion v) => WasmModuleV v -> GSWasm.ModuleInterfaceA iface -> t m (GSWasm.ModuleInterfaceA (PersistentInstrumentedModuleV v)) + recompileArtifact :: + forall v iface. + (IsWasmVersion v) => + WasmModuleV v -> + GSWasm.ModuleInterfaceA iface -> + t m (GSWasm.ModuleInterfaceA (PersistentInstrumentedModuleV (MBSStore (t m)) v)) recompileArtifact wasmMod oldIface = do case getWasmVersion @v of SV0 -> @@ -609,7 +655,11 @@ migrateModules migration mods = do -- Recompile a wasm module from the given source for protocol 7 -- cost semantics (i.e., the protocol version of @t m@). - migrateToP7 :: forall v. (MPV (t m) ~ P7, IsWasmVersion v) => WasmModuleV v -> t m (GSWasm.ModuleInterfaceA (PersistentInstrumentedModuleV v)) + migrateToP7 :: + forall v. + (MPV (t m) ~ P7, IsWasmVersion v) => + WasmModuleV v -> + t m (GSWasm.ModuleInterfaceA (PersistentInstrumentedModuleV (MBSStore (t m)) v)) migrateToP7 wasmMod = do case getWasmVersion @v of SV0 -> diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState/ProtocolLevelTokens.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState/ProtocolLevelTokens.hs index f2397f2b2c..f0b124a127 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState/ProtocolLevelTokens.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState/ProtocolLevelTokens.hs @@ -83,16 +83,16 @@ type TokenStateKey = BS.ByteString type TokenStateValue = BS.ByteString -- | The state of a particular protocol-level token. -data PLT = PLT +data PLT store = PLT { -- | The token configuration. - _pltConfiguration :: !(HashedBufferedRef' PLTConfigurationHash PLTConfiguration), + _pltConfiguration :: !(HashedBufferedRef' PLTConfigurationHash store PLTConfiguration), -- | The token-level state of the PLT. - _pltState :: !StateV1.PersistentState, + _pltState :: !(StateV1.PersistentState store), -- | The total amount of the token that exists in circulation. _pltCirculatingSupply :: !TokenRawAmount } -instance (MonadBlobStore m) => BlobStorable m PLT where +instance (MonadBlobStore m, store ~ MBSStore m) => BlobStorable m (PLT store) where load = do configRef <- load stateRef <- load @@ -110,12 +110,12 @@ instance (MonadBlobStore m) => BlobStorable m PLT where put (_pltCirculatingSupply plt) return $!! (thePutter, plt{_pltConfiguration = newConfig, _pltState = newState}) -instance (MonadBlobStore m) => Cacheable m PLT where +instance (MonadBlobStore m, store ~ MBSStore m) => Cacheable m (PLT store) where cache plt = do cachedConfiguration <- cache (_pltConfiguration plt) return plt{_pltConfiguration = cachedConfiguration} -instance (MonadBlobStore m) => MHashableTo m SHA256.Hash PLT where +instance (MonadBlobStore m, store ~ MBSStore m) => MHashableTo m SHA256.Hash (PLT store) where getHashM PLT{..} = do (PLTConfigurationHash configHash) <- getHashM _pltConfiguration tokenStateHash :: SHA256.Hash <- getHashM _pltState @@ -124,7 +124,7 @@ instance (MonadBlobStore m) => MHashableTo m SHA256.Hash PLT where put _pltCirculatingSupply return $! SHA256.hashOfHashes configHash stateHash -type TokenRef = HashedBufferedRef PLT +type TokenRef store = HashedBufferedRef store (PLT store) -- Normalized version of 'TokenId'. Normalized here means with all letters capitalized. -- The 'TokenIndex' is stored under a 'NormalizedTokenId', so when looking up a token, it is first @@ -137,9 +137,9 @@ normalizeTokenId :: TokenId -> NormalizedTokenId normalizeTokenId (TokenId tid) = NormalizedTokenId $ BSC.map toUpper $ SBS.fromShort tid -- | The table holding the protocol level token state. -data ProtocolLevelTokens = ProtocolLevelTokens +data ProtocolLevelTokens store = ProtocolLevelTokens { -- | The table of PLTs. - _pltTable :: !(LFMBTree.LFMBTree' TokenIndex HashedBufferedRef TokenRef), + _pltTable :: !(LFMBTree.LFMBTree' TokenIndex (HashedBufferedRef store) (TokenRef store)), -- | A map from 'TokenId's to 'TokenIndex'es. This is constructed, rather than stored. -- TODO: In future it would likely make sense to handle this with a difference map and store -- the finalized map in the LMDB database. (As, for instance, for modules.) @@ -147,7 +147,7 @@ data ProtocolLevelTokens = ProtocolLevelTokens _pltMap :: !(Map.Map NormalizedTokenId TokenIndex) } -instance (MonadBlobStore m) => BlobStorable m ProtocolLevelTokens where +instance (MonadBlobStore m, store ~ MBSStore m) => BlobStorable m (ProtocolLevelTokens store) where load = do loadTable <- load return $ do @@ -163,7 +163,7 @@ instance (MonadBlobStore m) => BlobStorable m ProtocolLevelTokens where (putTable, newTable) <- storeUpdate (_pltTable plts) return (putTable, plts{_pltTable = newTable}) -instance (MonadBlobStore m) => Cacheable m ProtocolLevelTokens where +instance (MonadBlobStore m, store ~ MBSStore m) => Cacheable m (ProtocolLevelTokens store) where cache ProtocolLevelTokens{..} = do pltTable' <- cache _pltTable return ProtocolLevelTokens{_pltTable = pltTable', ..} @@ -173,13 +173,16 @@ instance (MonadBlobStore m) => Cacheable m ProtocolLevelTokens where newtype ProtocolLevelTokensHash = ProtocolLevelTokensHash {theProtocolLevelTokensHash :: SHA256.Hash} deriving newtype (Eq, Ord, Show, Serialize) -instance (MonadBlobStore m) => MHashableTo m ProtocolLevelTokensHash ProtocolLevelTokens where +instance + (MonadBlobStore m, store ~ MBSStore m) => + MHashableTo m ProtocolLevelTokensHash (ProtocolLevelTokens store) + where getHashM ProtocolLevelTokens{..} = ProtocolLevelTokensHash . theLFMBTreeHash @BlockHashVersion1 <$> getHashM _pltTable -- | An empty 'ProtocolLevelTokens' structure. -emptyProtocolLevelTokens :: ProtocolLevelTokens +emptyProtocolLevelTokens :: ProtocolLevelTokens store emptyProtocolLevelTokens = ProtocolLevelTokens { _pltTable = LFMBTree.empty, @@ -188,13 +191,16 @@ emptyProtocolLevelTokens = -- | Protocol level tokens where supported by the protocol version. -- The 'ProtocolLevelTokens' structure is stored under a 'HashedBufferedRef''. -newtype ProtocolLevelTokensForPV (pv :: ProtocolVersion) = ProtocolLevelTokensForPV +newtype ProtocolLevelTokensForPV store (pv :: ProtocolVersion) = ProtocolLevelTokensForPV { theProtocolLevelTokensForPV :: (Conditionally (SupportsPLT (AccountVersionFor pv))) - (HashedBufferedRef' ProtocolLevelTokensHash ProtocolLevelTokens) + (HashedBufferedRef' ProtocolLevelTokensHash store (ProtocolLevelTokens store)) } -instance (MonadBlobStore m, IsProtocolVersion pv) => BlobStorable m (ProtocolLevelTokensForPV pv) where +instance + (MonadBlobStore m, IsProtocolVersion pv, store ~ MBSStore m) => + BlobStorable m (ProtocolLevelTokensForPV store pv) + where load = case sSupportsPLT (accountVersion @(AccountVersionFor pv)) of SFalse -> return (return (ProtocolLevelTokensForPV CFalse)) STrue -> fmap (ProtocolLevelTokensForPV . CTrue) <$> load @@ -205,19 +211,22 @@ instance (MonadBlobStore m, IsProtocolVersion pv) => BlobStorable m (ProtocolLev return (ppltRef, ProtocolLevelTokensForPV (CTrue pltRef')) instance - (MonadBlobStore m, b ~ SupportsPLT (AccountVersionFor pv)) => - MHashableTo m (Conditionally b ProtocolLevelTokensHash) (ProtocolLevelTokensForPV pv) + (MonadBlobStore m, b ~ SupportsPLT (AccountVersionFor pv), store ~ MBSStore m) => + MHashableTo m (Conditionally b ProtocolLevelTokensHash) (ProtocolLevelTokensForPV store pv) where getHashM (ProtocolLevelTokensForPV CFalse) = return CFalse getHashM (ProtocolLevelTokensForPV (CTrue ref)) = CTrue <$> getHashM ref instance - (MonadBlobStore m, PVSupportsPLT pv) => - MHashableTo m ProtocolLevelTokensHash (ProtocolLevelTokensForPV pv) + (MonadBlobStore m, PVSupportsPLT pv, store ~ MBSStore m) => + MHashableTo m ProtocolLevelTokensHash (ProtocolLevelTokensForPV store pv) where getHashM (ProtocolLevelTokensForPV (CTrue ref)) = getHashM ref -instance (MonadBlobStore m) => Cacheable m (ProtocolLevelTokensForPV pv) where +instance + (MonadBlobStore m, store ~ MBSStore m) => + Cacheable m (ProtocolLevelTokensForPV store pv) + where cache (ProtocolLevelTokensForPV (CTrue pltsRef)) = ProtocolLevelTokensForPV . CTrue <$> cache pltsRef cache pvPLTs = pure pvPLTs @@ -225,15 +234,15 @@ instance (MonadBlobStore m) => Cacheable m (ProtocolLevelTokensForPV pv) where -- | Load a 'ProtocolLevelTokens' from a 'ProtocolLevelTokensForPV'. loadPLTs :: (PVSupportsPLT pv, MonadBlobStore m) => - ProtocolLevelTokensForPV pv -> - m ProtocolLevelTokens + ProtocolLevelTokensForPV (MBSStore m) pv -> + m (ProtocolLevelTokens (MBSStore m)) loadPLTs = refLoad . uncond . theProtocolLevelTokensForPV -- | Store a 'ProtocolLevelTokens' in a 'ProtocolLevelTokensForPV'. storePLTs :: (PVSupportsPLT pv, MonadBlobStore m) => - ProtocolLevelTokens -> - m (ProtocolLevelTokensForPV pv) + ProtocolLevelTokens (MBSStore m) -> + m (ProtocolLevelTokensForPV (MBSStore m) pv) storePLTs = fmap (ProtocolLevelTokensForPV . CTrue) . refMake -- | Store a 'ProtocolLevelTokens' in a 'ProtocolLevelTokensForPV' if the protocol version supports @@ -241,8 +250,8 @@ storePLTs = fmap (ProtocolLevelTokensForPV . CTrue) . refMake conditionallyStorePLTs :: forall m pv. (IsProtocolVersion pv, MonadBlobStore m) => - ProtocolLevelTokens -> - m (ProtocolLevelTokensForPV pv) + ProtocolLevelTokens (MBSStore m) -> + m (ProtocolLevelTokensForPV (MBSStore m) pv) conditionallyStorePLTs = case sSupportsPLT (accountVersion @(AccountVersionFor pv)) of STrue -> storePLTs SFalse -> const (return $ ProtocolLevelTokensForPV CFalse) @@ -250,12 +259,12 @@ conditionallyStorePLTs = case sSupportsPLT (accountVersion @(AccountVersionFor p -- | An empty 'ProtocolLevelTokensForPV' with no tokens. emptyProtocolLevelTokensForPV :: (IsProtocolVersion pv, MonadBlobStore m) => - m (ProtocolLevelTokensForPV pv) + m (ProtocolLevelTokensForPV (MBSStore m) pv) emptyProtocolLevelTokensForPV = conditionallyStorePLTs emptyProtocolLevelTokens -- | Get the list of all existing protocol-level tokens by their 'TokenId's. -- This returns the empty list when the protocol version does not support PLTs. -getPLTList :: (MonadBlobStore m) => ProtocolLevelTokensForPV pv -> m [TokenId] +getPLTList :: (MonadBlobStore m) => ProtocolLevelTokensForPV (MBSStore m) pv -> m [TokenId] getPLTList (ProtocolLevelTokensForPV CFalse) = return [] getPLTList (ProtocolLevelTokensForPV (CTrue plts)) = do table <- _pltTable <$> refLoad plts @@ -270,7 +279,7 @@ getPLTList (ProtocolLevelTokensForPV (CTrue plts)) = do getTokenIndex :: (PVSupportsPLT pv, MonadBlobStore m) => TokenId -> - ProtocolLevelTokensForPV pv -> + ProtocolLevelTokensForPV (MBSStore m) pv -> m (Maybe TokenIndex) getTokenIndex tokId = fmap (Map.lookup ntid . _pltMap) . loadPLTs where @@ -282,8 +291,8 @@ getTokenIndex tokId = fmap (Map.lookup ntid . _pltMap) . loadPLTs lookupPLT :: (PVSupportsPLT pv, MonadBlobStore m) => TokenIndex -> - ProtocolLevelTokensForPV pv -> - m PLT + ProtocolLevelTokensForPV (MBSStore m) pv -> + m (PLT (MBSStore m)) lookupPLT index pvPLTs = do plts <- loadPLTs pvPLTs mPLT <- LFMBTree.lookup index (_pltTable plts) @@ -299,8 +308,8 @@ lookupPLT index pvPLTs = do getMutableTokenState :: (PVSupportsPLT pv, MonadBlobStore m) => TokenIndex -> - ProtocolLevelTokensForPV pv -> - m StateV1.MutableState + ProtocolLevelTokensForPV (MBSStore m) pv -> + m (StateV1.MutableState (MBSStore m)) getMutableTokenState index pvPLTs = do plt <- lookupPLT index pvPLTs loadCallback <- fst <$> getCallbacks @@ -313,9 +322,9 @@ getMutableTokenState index pvPLTs = do setTokenState :: (PVSupportsPLT pv, MonadBlobStore m) => TokenIndex -> - StateV1.MutableState -> - ProtocolLevelTokensForPV pv -> - m (ProtocolLevelTokensForPV pv) + StateV1.MutableState (MBSStore m) -> + ProtocolLevelTokensForPV (MBSStore m) pv -> + m (ProtocolLevelTokensForPV (MBSStore m) pv) setTokenState index mutableState pvPLTs = do plts <- loadPLTs pvPLTs LFMBTree.update upd index (_pltTable plts) >>= \case @@ -334,7 +343,7 @@ setTokenState index mutableState pvPLTs = do lookupTokenState :: (MonadBlobStore m) => TokenStateKey -> - StateV1.MutableState -> + StateV1.MutableState (MBSStore m) -> m (Maybe TokenStateValue) lookupTokenState key mutableState = liftIO $ StateV1.lookupMutableState key mutableState @@ -349,7 +358,7 @@ updateTokenState :: (MonadBlobStore m) => TokenStateKey -> Maybe TokenStateValue -> - StateV1.MutableState -> + StateV1.MutableState (MBSStore m) -> m (Maybe Bool) updateTokenState key maybeValue mutableState = liftIO $ case maybeValue of @@ -362,7 +371,7 @@ updateTokenState key maybeValue mutableState = getTokenConfiguration :: (PVSupportsPLT pv, MonadBlobStore m) => TokenIndex -> - ProtocolLevelTokensForPV pv -> + ProtocolLevelTokensForPV (MBSStore m) pv -> m PLTConfiguration getTokenConfiguration index pvPLTs = do plt <- lookupPLT index pvPLTs @@ -374,7 +383,7 @@ getTokenConfiguration index pvPLTs = do getTokenCirculatingSupply :: (PVSupportsPLT pv, MonadBlobStore m) => TokenIndex -> - ProtocolLevelTokensForPV pv -> + ProtocolLevelTokensForPV (MBSStore m) pv -> m TokenRawAmount getTokenCirculatingSupply index pvPLTs = do plt <- lookupPLT index pvPLTs @@ -388,8 +397,8 @@ setTokenCirculatingSupply :: (PVSupportsPLT pv, MonadBlobStore m) => TokenIndex -> TokenRawAmount -> - ProtocolLevelTokensForPV pv -> - m (ProtocolLevelTokensForPV pv) + ProtocolLevelTokensForPV (MBSStore m) pv -> + m (ProtocolLevelTokensForPV (MBSStore m) pv) setTokenCirculatingSupply index newSupply pvPLTs = do plts <- loadPLTs pvPLTs LFMBTree.update upd index (_pltTable plts) >>= \case @@ -410,8 +419,8 @@ setTokenCirculatingSupply index newSupply pvPLTs = do createToken :: (PVSupportsPLT pv, MonadBlobStore m) => PLTConfiguration -> - ProtocolLevelTokensForPV pv -> - m (TokenIndex, ProtocolLevelTokensForPV pv) + ProtocolLevelTokensForPV (MBSStore m) pv -> + m (TokenIndex, ProtocolLevelTokensForPV (MBSStore m) pv) createToken config pvPLTs = do plts <- loadPLTs pvPLTs newConfigRef <- refMake config @@ -431,12 +440,13 @@ createToken config pvPLTs = do migrateProtocolLevelTokens :: forall t m. (SupportMigration m t) => - ProtocolLevelTokens -> - t m ProtocolLevelTokens + ProtocolLevelTokens (MBSStore m) -> + t m (ProtocolLevelTokens (MBSStore (t m))) migrateProtocolLevelTokens ProtocolLevelTokens{..} = do newTable <- LFMBTree.migrateLFMBTree (migrateHashedBufferedRef migratePLT) _pltTable return ProtocolLevelTokens{_pltTable = newTable, _pltMap = _pltMap} where + migratePLT :: PLT (MBSStore m) -> t m (PLT (MBSStore (t m))) migratePLT PLT{..} = do newConfig <- migrateHashedBufferedRefKeepHash _pltConfiguration (oldLoadCallback, _) <- lift getCallbacks @@ -460,8 +470,8 @@ migrateProtocolLevelTokensForPV :: MonadProtocolVersion (t m) ) => StateMigrationParameters (MPV m) (MPV (t m)) -> - ProtocolLevelTokensForPV (MPV m) -> - t m (ProtocolLevelTokensForPV (MPV (t m))) + ProtocolLevelTokensForPV (MBSStore m) (MPV m) -> + t m (ProtocolLevelTokensForPV (MBSStore (t m)) (MPV (t m))) migrateProtocolLevelTokensForPV _ (ProtocolLevelTokensForPV CFalse) = do -- When migrating from a version where there are no protocol-level tokens, we use the -- empty protocol level tokens (if the new state supports LTS). diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState/Updates.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState/Updates.hs index 145f62c5f1..075845057b 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState/Updates.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState/Updates.hs @@ -681,7 +681,7 @@ instance return PendingUpdates{..} instance - (MonadBlobStore m, store ~ MBSStore m IsChainParametersVersion cpv, IsAuthorizationsVersion auv) => + (MonadBlobStore m, store ~ MBSStore m, IsChainParametersVersion cpv, IsAuthorizationsVersion auv) => Cacheable m (PendingUpdates store cpv auv) where cache PendingUpdates{..} = @@ -784,7 +784,6 @@ makeBasicPendingUpdates PendingUpdates{..} = withCPVConstraints (chainParameters -- | Current state of updatable parameters and update queues. data Updates' store (cpv :: ChainParametersVersion) (auv :: AuthorizationsVersion) = Updates { -- | Current update authorizations. - currentKeyCollection :: !(HashedBufferedRef store (StoreSerialized (UpdateKeysCollection (AuthorizationsVersionFor cpv)))), currentKeyCollection :: !(HashedBufferedRef store (StoreSerialized (UpdateKeysCollection auv))), -- | Current protocol update. currentProtocolUpdate :: !(Nullable (HashedBufferedRef store (StoreSerialized ProtocolUpdate))), @@ -1057,7 +1056,7 @@ processLevel2KeysUpdates t bu = do processElectionDifficultyUpdates :: (MonadBlobStore m, IsChainParametersVersion cpv, IsAuthorizationsVersion auv) => Timestamp -> - BufferedRef (Updates' (MBSStore m) cpv auv) -> + BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv auv) -> m (Map.Map TransactionTime (UpdateValue cpv auv), BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv auv)) processElectionDifficultyUpdates t bu = do u@Updates{..} <- refLoad bu @@ -1083,7 +1082,7 @@ processElectionDifficultyUpdates t bu = do processEuroPerEnergyUpdates :: (MonadBlobStore m, IsChainParametersVersion cpv, IsAuthorizationsVersion auv) => Timestamp -> - BufferedRef (Updates' (MBSStore m) cpv auv) -> + BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv auv) -> m (Map.Map TransactionTime (UpdateValue cpv auv), BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv auv)) processEuroPerEnergyUpdates t bu = do u@Updates{..} <- refLoad bu @@ -1104,7 +1103,7 @@ processEuroPerEnergyUpdates t bu = do processMicroGTUPerEuroUpdates :: (MonadBlobStore m, IsChainParametersVersion cpv, IsAuthorizationsVersion auv) => Timestamp -> - BufferedRef (Updates' (MBSStore m) cpv auv) -> + BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv auv) -> m (Map.Map TransactionTime (UpdateValue cpv auv), BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv auv)) processMicroGTUPerEuroUpdates t bu = do u@Updates{..} <- refLoad bu @@ -1124,7 +1123,7 @@ processMicroGTUPerEuroUpdates t bu = do processFoundationAccountUpdates :: (MonadBlobStore m, IsChainParametersVersion cpv, IsAuthorizationsVersion auv) => Timestamp -> - BufferedRef (Updates' (MBSStore m) cpv auv) -> + BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv auv) -> m (Map.Map TransactionTime (UpdateValue cpv auv), BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv auv)) processFoundationAccountUpdates t bu = do u@Updates{..} <- refLoad bu @@ -1145,7 +1144,7 @@ processMintDistributionUpdates :: forall m cpv auv. (MonadBlobStore m, IsChainParametersVersion cpv, IsAuthorizationsVersion auv) => Timestamp -> - BufferedRef (Updates' (MBSStore m) cpv auv) -> + BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv auv) -> m (Map.Map TransactionTime (UpdateValue cpv auv), BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv auv)) processMintDistributionUpdates t bu = withIsMintDistributionVersionFor (chainParametersVersion @cpv) $ do u@Updates{..} <- refLoad bu @@ -1165,7 +1164,7 @@ processMintDistributionUpdates t bu = withIsMintDistributionVersionFor (chainPar processTransactionFeeDistributionUpdates :: (MonadBlobStore m, IsChainParametersVersion cpv, IsAuthorizationsVersion auv) => Timestamp -> - BufferedRef (Updates' (MBSStore m) cpv auv) -> + BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv auv) -> m (Map.Map TransactionTime (UpdateValue cpv auv), BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv auv)) processTransactionFeeDistributionUpdates t bu = do u@Updates{..} <- refLoad bu @@ -1186,7 +1185,7 @@ processGASRewardsUpdates :: forall m cpv auv. (MonadBlobStore m, IsChainParametersVersion cpv, IsAuthorizationsVersion auv) => Timestamp -> - BufferedRef (Updates' (MBSStore m) cpv auv) -> + BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv auv) -> m (Map.Map TransactionTime (UpdateValue cpv auv), BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv auv)) processGASRewardsUpdates t bu = withIsGASRewardsVersionFor (chainParametersVersion @cpv) $ do u@Updates{..} <- refLoad bu @@ -1207,7 +1206,7 @@ processPoolParamatersUpdates :: forall m cpv auv. (MonadBlobStore m, IsChainParametersVersion cpv, IsAuthorizationsVersion auv) => Timestamp -> - BufferedRef (Updates' (MBSStore m) cpv auv) -> + BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv auv) -> m (Map.Map TransactionTime (UpdateValue cpv auv), BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv auv)) processPoolParamatersUpdates t bu = withIsPoolParametersVersionFor (chainParametersVersion @cpv) $ do u@Updates{..} <- refLoad bu @@ -1229,7 +1228,7 @@ processCooldownParametersUpdates :: forall m cpv auv. (MonadBlobStore m, IsChainParametersVersion cpv, IsAuthorizationsVersion auv) => Timestamp -> - BufferedRef (Updates' (MBSStore m) cpv auv) -> + BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv auv) -> m (Map.Map TransactionTime (UpdateValue cpv auv), BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv auv)) processCooldownParametersUpdates t bu = do u@Updates{..} <- refLoad bu @@ -1253,7 +1252,7 @@ processCooldownParametersUpdates t bu = do processTimeParametersUpdates :: (MonadBlobStore m, IsChainParametersVersion cpv, IsAuthorizationsVersion auv) => Timestamp -> - BufferedRef (Updates' (MBSStore m) cpv auv) -> + BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv auv) -> m (Map.Map TransactionTime (UpdateValue cpv auv), BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv auv)) processTimeParametersUpdates t bu = do u@Updates{..} <- refLoad bu @@ -1281,7 +1280,7 @@ processTimeoutParametersUpdates :: forall m cpv auv. (MonadBlobStore m, IsChainParametersVersion cpv, IsAuthorizationsVersion auv) => Timestamp -> - BufferedRef (Updates' (MBSStore m) cpv auv) -> + BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv auv) -> m (Map.Map TransactionTime (UpdateValue cpv auv), BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv auv)) processTimeoutParametersUpdates t bu = do u@Updates{..} <- refLoad bu @@ -1311,7 +1310,7 @@ processMinBlockTimeUpdates :: forall m cpv auv. (MonadBlobStore m, IsChainParametersVersion cpv, IsAuthorizationsVersion auv) => Timestamp -> - BufferedRef (Updates' (MBSStore m) cpv auv) -> + BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv auv) -> m (Map.Map TransactionTime (UpdateValue cpv auv), BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv auv)) processMinBlockTimeUpdates t bu = do u@Updates{..} <- refLoad bu @@ -1341,7 +1340,7 @@ processBlockEnergyLimitUpdates :: forall m cpv auv. (MonadBlobStore m, IsChainParametersVersion cpv, IsAuthorizationsVersion auv) => Timestamp -> - BufferedRef (Updates' (MBSStore m) cpv auv) -> + BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv auv) -> m (Map.Map TransactionTime (UpdateValue cpv auv), BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv auv)) processBlockEnergyLimitUpdates t bu = do u@Updates{..} <- refLoad bu @@ -1403,8 +1402,8 @@ processValidationScoreParametersUpdates :: forall m cpv auv. (MonadBlobStore m, IsChainParametersVersion cpv, IsAuthorizationsVersion auv) => Timestamp -> - BufferedRef (Updates' cpv auv) -> - m (Map.Map TransactionTime (UpdateValue cpv auv), BufferedRef (Updates' cpv auv)) + BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv auv) -> + m (Map.Map TransactionTime (UpdateValue cpv auv), BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv auv)) processValidationScoreParametersUpdates t bu = do u@Updates{..} <- refLoad bu case pValidatorScoreParametersQueue pendingUpdates of @@ -1794,8 +1793,8 @@ enqueueUpdate effectiveTime payload uref = withCPVConstraints (chainParametersVe incrementPLTUpdateSequenceNumber :: forall m cpv auv. (MonadBlobStore m, IsChainParametersVersion cpv, IsAuthorizationsVersion auv, SupportsCreatePLT auv ~ 'True) => - BufferedRef (Updates' cpv auv) -> - m (BufferedRef (Updates' cpv auv)) + BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv auv) -> + m (BufferedRef (MBSStore m) (Updates' (MBSStore m) cpv auv)) incrementPLTUpdateSequenceNumber updatesRef = do currentUpdates <- refLoad updatesRef let currentSequenceNumber = uncond $ pltUpdateSequenceNumber currentUpdates diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/CachedRef.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/CachedRef.hs index 6996c749f7..14f6049856 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/CachedRef.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/CachedRef.hs @@ -459,11 +459,11 @@ openHashedCachedRef :: forall m h c a. ( MonadCache c m, Cache c, - CacheKey c ~ BlobRef a, + CacheKey c ~ BlobRef (MBSStore m) a, CacheValue c ~ a ) => - HashedCachedRef' h c a -> - m (Either (BlobRef a) a) + HashedCachedRef' h (MBSStore m) c a -> + m (Either (BlobRef (MBSStore m) a) a) openHashedCachedRef HCRUnflushed{..} = liftIO (readIORef hcrUnflushed) >>= \case HCRMem val -> return (Right val) diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Cooldown.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Cooldown.hs index f230bcaf70..dcdf51ee4f 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Cooldown.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Cooldown.hs @@ -23,12 +23,12 @@ import Concordium.Types.Conditionally import Concordium.Types.Option -- | An 'AccountIndex' and the (possibly empty) tail of the list. -data AccountListItem = AccountListItem +data AccountListItem store = AccountListItem { accountListEntry :: !AccountIndex, - accountListTail :: !AccountList + accountListTail :: !(AccountList store) } -instance (MonadBlobStore m) => BlobStorable m AccountListItem where +instance (MonadBlobStore m, store ~ MBSStore m) => BlobStorable m (AccountListItem store) where load = do mAccountListEntry <- load mAccountListTail <- load @@ -41,23 +41,29 @@ instance (MonadBlobStore m) => BlobStorable m AccountListItem where ) -- | A possibly empty list of 'AccountIndex'es, stored under 'UnbufferedRef's. -type AccountList = Nullable (UnbufferedRef AccountListItem) +type AccountList store = Nullable (UnbufferedRef store (AccountListItem store)) -- | Prepend an 'AccountIndex' to an 'AccountList'. -consAccountList :: (MonadBlobStore m) => AccountIndex -> AccountList -> m AccountList +consAccountList :: + (MonadBlobStore m) => + AccountIndex -> AccountList (MBSStore m) -> m (AccountList (MBSStore m)) consAccountList accountIndex accountList = do ref <- refMake (AccountListItem accountIndex accountList) return (Some ref) -- | Load an entire account list. This is intended for testing purposes. -loadAccountList :: (MonadBlobStore m) => AccountList -> m [AccountIndex] +loadAccountList :: + (MonadBlobStore m) => + AccountList (MBSStore m) -> m [AccountIndex] loadAccountList Null = return [] loadAccountList (Some ref) = do AccountListItem{..} <- refLoad ref (accountListEntry :) <$> loadAccountList accountListTail -- | Migrate an 'AccountList' from one context to another. -migrateAccountList :: (SupportMigration m t) => AccountList -> t m AccountList +migrateAccountList :: + (SupportMigration m t) => + AccountList (MBSStore m) -> t m (AccountList (MBSStore (t m))) migrateAccountList Null = return Null migrateAccountList (Some ubRef) = do Some <$> migrateReference migrateAccountListItem ubRef @@ -69,7 +75,9 @@ migrateAccountList (Some ubRef) = do -- | Remove the first instance of an 'AccountIndex' from an 'AccountList'. -- (This should only be used when the 'AccountIndex' is expected to be in the list. Otherwise, -- the entire list will be effectively duplicated in the blob store for no reason.) -removeAccountFromAccountList :: (MonadBlobStore m) => AccountIndex -> AccountList -> m AccountList +removeAccountFromAccountList :: + (MonadBlobStore m) => + AccountIndex -> AccountList (MBSStore m) -> m (AccountList (MBSStore m)) removeAccountFromAccountList ai alist = case alist of Null -> return Null Some ref -> do @@ -89,13 +97,13 @@ removeAccountFromAccountList ai alist = case alist of -- | An index of the accounts that are currently in cooldown/pre-cooldown/pre-pre-cooldown. -- As this is an indexing structure, it is not hashed as part of the block state hash. -data AccountsInCooldown = AccountsInCooldown +data AccountsInCooldown store = AccountsInCooldown { -- | The accounts that are in cooldown with their earliest release times. - _cooldown :: !NewReleaseSchedule, + _cooldown :: !(NewReleaseSchedule store), -- | The accounts that are in pre-cooldown. - _preCooldown :: !AccountList, + _preCooldown :: !(AccountList store), -- | The accounts that are in pre-pre-cooldown. - _prePreCooldown :: !AccountList + _prePreCooldown :: !(AccountList store) } makeLenses ''AccountsInCooldown @@ -103,10 +111,10 @@ makeLenses ''AccountsInCooldown -- | The cacheable instance only caches the 'cooldown' field, since the -- 'preCooldown' and 'prePreCooldown' are implemented using 'UnbufferedRef's (and so -- would have no benefit from caching). -instance (MonadBlobStore m) => Cacheable m AccountsInCooldown where +instance (MonadBlobStore m, store ~ MBSStore m) => Cacheable m (AccountsInCooldown store) where cache = cooldown cache -instance (MonadBlobStore m) => BlobStorable m AccountsInCooldown where +instance (MonadBlobStore m, store ~ MBSStore m) => BlobStorable m (AccountsInCooldown store) where load = do mCooldown <- load mPreCooldown <- load @@ -127,7 +135,7 @@ instance (MonadBlobStore m) => BlobStorable m AccountsInCooldown where ) -- | An 'AccountsInCooldown' with no accounts in (pre)*cooldown. -emptyAccountsInCooldown :: AccountsInCooldown +emptyAccountsInCooldown :: AccountsInCooldown store emptyAccountsInCooldown = AccountsInCooldown { _cooldown = emptyNewReleaseSchedule, @@ -138,8 +146,8 @@ emptyAccountsInCooldown = -- | Migrate 'AccountsInCooldown' from one 'BlobStore' to another. migrateAccountsInCooldown :: (SupportMigration m t) => - AccountsInCooldown -> - t m AccountsInCooldown + AccountsInCooldown (MBSStore m) -> + t m (AccountsInCooldown (MBSStore (t m))) migrateAccountsInCooldown aic = do newCooldown <- migrateNewReleaseSchedule (_cooldown aic) newPreCooldown <- migrateAccountList (_preCooldown aic) @@ -153,12 +161,15 @@ migrateAccountsInCooldown aic = do -- | A type that holds an 'AccountsInCooldown' for protocol versions that support flexible -- cooldowns (and nothing for versions that do not). -newtype AccountsInCooldownForPV (pv :: ProtocolVersion) = AccountsInCooldownForPV +newtype AccountsInCooldownForPV store (pv :: ProtocolVersion) = AccountsInCooldownForPV { theAccountsInCooldownForPV :: - Conditionally (SupportsFlexibleCooldown (AccountVersionFor pv)) AccountsInCooldown + Conditionally (SupportsFlexibleCooldown (AccountVersionFor pv)) (AccountsInCooldown store) } -instance (MonadBlobStore m, IsProtocolVersion pv) => BlobStorable m (AccountsInCooldownForPV pv) where +instance + (MonadBlobStore m, IsProtocolVersion pv, store ~ MBSStore m) => + BlobStorable m (AccountsInCooldownForPV store pv) + where load = case sSupportsFlexibleCooldown (accountVersion @(AccountVersionFor pv)) of SFalse -> return (return (AccountsInCooldownForPV CFalse)) STrue -> fmap (AccountsInCooldownForPV . CTrue) <$> load @@ -172,7 +183,7 @@ instance (MonadBlobStore m, IsProtocolVersion pv) => BlobStorable m (AccountsInC -- protocol version supports flexible cooldown. accountsInCooldown :: (PVSupportsFlexibleCooldown pv) => - Lens' (AccountsInCooldownForPV pv) AccountsInCooldown + Lens' (AccountsInCooldownForPV store pv) (AccountsInCooldown store) accountsInCooldown = lens (uncond . theAccountsInCooldownForPV) @@ -180,15 +191,18 @@ accountsInCooldown = -- | An 'AccountsInCooldownForPV' with no accounts in (pre)*cooldown. emptyAccountsInCooldownForPV :: - forall pv. + forall store pv. (IsProtocolVersion pv) => - AccountsInCooldownForPV pv + AccountsInCooldownForPV store pv emptyAccountsInCooldownForPV = AccountsInCooldownForPV (conditionally cond emptyAccountsInCooldown) where cond = sSupportsFlexibleCooldown (accountVersion @(AccountVersionFor pv)) -instance (MonadBlobStore m) => Cacheable m (AccountsInCooldownForPV pv) where +instance + (MonadBlobStore m, store ~ MBSStore m) => + Cacheable m (AccountsInCooldownForPV store pv) + where cache = fmap AccountsInCooldownForPV . mapM cache . theAccountsInCooldownForPV -- | Generate the initial 'AccountsInCooldownForPV' structure from the initial accounts. @@ -196,8 +210,8 @@ instance (MonadBlobStore m) => Cacheable m (AccountsInCooldownForPV pv) where initialAccountsInCooldown :: forall pv m. (MonadBlobStore m, IsProtocolVersion pv) => - [PersistentAccount (AccountVersionFor pv)] -> - m (AccountsInCooldownForPV pv) + [PersistentAccount (MBSStore m) (AccountVersionFor pv)] -> + m (AccountsInCooldownForPV (MBSStore m) pv) initialAccountsInCooldown accounts = case sSupportsFlexibleCooldown sAV of SFalse -> return emptyAccountsInCooldownForPV STrue -> do @@ -244,9 +258,9 @@ migrateAccountsInCooldownForPV :: ( Not (SupportsFlexibleCooldown (AccountVersionFor oldpv)) && SupportsFlexibleCooldown (AccountVersionFor pv) ) - AccountList -> - AccountsInCooldownForPV oldpv -> - t m (AccountsInCooldownForPV pv) + (AccountList (MBSStore (t m))) -> + AccountsInCooldownForPV (MBSStore m) oldpv -> + t m (AccountsInCooldownForPV (MBSStore (t m)) pv) migrateAccountsInCooldownForPV = case sSupportsFlexibleCooldown (accountVersion @(AccountVersionFor pv)) of SFalse -> \_ _ -> return emptyAccountsInCooldownForPV diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Genesis.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Genesis.hs index 4987c2d501..e36bb9ea85 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Genesis.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Genesis.hs @@ -59,10 +59,10 @@ import Lens.Micro.Platform -- This also returns the transaction table. -- The result is immediately flushed to disc and cached. genesisState :: - forall pv av m. - (BS.SupportsPersistentState pv m, Types.AccountVersionFor pv ~ av) => + forall store pv av m. + (BS.SupportsPersistentState store pv m, Types.AccountVersionFor pv ~ av) => GenesisData.GenesisData pv -> - m (Either String (BS.HashedPersistentBlockState pv, TransactionTable.TransactionTable)) + m (Either String (BS.HashedPersistentBlockState store pv, TransactionTable.TransactionTable)) genesisState gd = MTL.runExceptT $ case Types.protocolVersion @pv of Types.SP1 -> case gd of GenesisData.GDP1 P1.GDP1Initial{..} -> @@ -104,19 +104,19 @@ data VersionedCoreGenesisParameters (pv :: Types.ProtocolVersion) where -- | State being accumulated while iterating the accounts in genesis data. -- It is then used to construct the initial block state from genesis. -data AccumGenesisState pv = AccumGenesisState +data AccumGenesisState store pv = AccumGenesisState { -- | Tracking all the accounts. - agsAllAccounts :: !(Accounts.Accounts pv), + agsAllAccounts :: !(Accounts.Accounts store pv), -- | Collection of the IDs of the active bakers. - agsBakerIds :: !(Bakers.BakerIdTrieMap (Types.AccountVersionFor pv)), + agsBakerIds :: !(Bakers.BakerIdTrieMap store (Types.AccountVersionFor pv)), -- | Collection of the aggregation keys of the active bakers. - agsBakerKeys :: !Bakers.AggregationKeySet, + agsBakerKeys :: !(Bakers.AggregationKeySet store), -- | Total amount owned by accounts. agsTotal :: !Types.Amount, -- | Total staked amount by bakers. agsStakedTotal :: !Types.Amount, -- | List of baker info refs in incremental order of the baker ID. - agsBakerInfoRefs :: !(Vec.Vector (Account.PersistentBakerInfoRef (Types.AccountVersionFor pv))), + agsBakerInfoRefs :: !(Vec.Vector (Account.PersistentBakerInfoRef store (Types.AccountVersionFor pv))), -- | List of baker stake in incremental order of the baker ID. -- Entries in this list should have a matching entry in agsBakerCapitals. -- In the end result these are needed separately and are therefore constructed separately. @@ -130,7 +130,7 @@ data AccumGenesisState pv = AccumGenesisState --------- Helper functions ---------- -- | The initial value for accumulating data from genesis data accounts. -initialAccumGenesisState :: (MTL.MonadIO m) => m (AccumGenesisState pv) +initialAccumGenesisState :: (MTL.MonadIO m) => m (AccumGenesisState store pv) initialAccumGenesisState = do emptyAccs <- Accounts.emptyAccounts return $ @@ -148,18 +148,18 @@ initialAccumGenesisState = do -- | Construct a hashed persistent block state from the data in genesis. -- The result is immediately flushed to disc and cached. buildGenesisBlockState :: - forall pv av m. - (BS.SupportsPersistentState pv m, Types.AccountVersionFor pv ~ av) => + forall store pv av m. + (BS.SupportsPersistentState store pv m, Types.AccountVersionFor pv ~ av) => VersionedCoreGenesisParameters pv -> GenesisData.GenesisState pv -> - MTL.ExceptT String m (BS.HashedPersistentBlockState pv, TransactionTable.TransactionTable) + MTL.ExceptT String m (BS.HashedPersistentBlockState store 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 initState genesisAccounts -- Birk parameters - persistentBirkParameters :: BS.PersistentBirkParameters pv <- do + persistentBirkParameters :: BS.PersistentBirkParameters store pv <- do _birkActiveBakers <- Blob.refMakeFlushed $ Bakers.PersistentActiveBakers @@ -202,7 +202,7 @@ buildGenesisBlockState vcgp GenesisData.GenesisState{..} = do Types.SAVDelegationSupported -> case Types.delegationChainParameters @pv of Types.DelegationChainParameters -> do - capRef :: Blob.HashedBufferedRef' (CapDist.CapitalDistributionHash pv) CapDist.CapitalDistribution <- + capRef :: Blob.HashedBufferedRef' (CapDist.CapitalDistributionHash pv) store CapDist.CapitalDistribution <- Blob.refMakeFlushed CapDist.CapitalDistribution { bakerPoolCapital = agsBakerCapitals, @@ -269,12 +269,12 @@ buildGenesisBlockState vcgp GenesisData.GenesisState{..} = do -- For iterating the genesis accounts and accumulating relevant states to build up the genesis block. accumStateFromGenesisAccounts :: -- The state being accumulated so far. - AccumGenesisState pv -> + AccumGenesisState store pv -> -- The index of the account Int -> -- Account from genesis to accumulate. GenesisData.GenesisAccount -> - MTL.ExceptT String m (AccumGenesisState pv) + MTL.ExceptT String m (AccumGenesisState store pv) accumStateFromGenesisAccounts state index genesisAccount = do -- Create the persistent account !persistentAccount <- diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Instances.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Instances.hs index d8a944e55c..ea55b22fc6 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Instances.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Instances.hs @@ -48,15 +48,15 @@ import Concordium.Logger (MonadLogger) -- | State of a smart contract parametrized by the contract version. This is the -- persistent version which supports storing and loading the state from a blob -- store. -data InstanceStateV (v :: Wasm.WasmVersion) where - InstanceStateV0 :: !Wasm.ContractState -> InstanceStateV GSWasm.V0 - InstanceStateV1 :: !StateV1.PersistentState -> InstanceStateV GSWasm.V1 +data InstanceStateV store (v :: Wasm.WasmVersion) where + InstanceStateV0 :: !Wasm.ContractState -> InstanceStateV state GSWasm.V0 + InstanceStateV1 :: !(StateV1.PersistentState store) -> InstanceStateV store GSWasm.V1 migrateInstanceStateV :: forall v t m. (SupportMigration m t) => - InstanceStateV v -> - t m (InstanceStateV v) + InstanceStateV (MBSStore m) v -> + t m (InstanceStateV (MBSStore (t m)) v) migrateInstanceStateV (InstanceStateV0 s) = return (InstanceStateV0 s) -- flat state, no inner references. migrateInstanceStateV (InstanceStateV1 s) = do (oldLoadCallback, _) <- lift getCallbacks @@ -111,16 +111,16 @@ instance (Applicative m) => Cacheable m PersistentInstanceParameters -- `v` that is used to tie the instance version to the module version. At -- present the version only appears in the module, but with the state changes it -- will also appear in the contract state. -data PersistentInstanceV (v :: Wasm.WasmVersion) = PersistentInstanceV +data PersistentInstanceV store (v :: Wasm.WasmVersion) = PersistentInstanceV { -- | The fixed parameters of the instance. - pinstanceParameters :: !(BufferedRef PersistentInstanceParameters), + pinstanceParameters :: !(BufferedRef store PersistentInstanceParameters), -- | The interface of 'pinstanceContractModule'. Note this is a 'HashedCachedRef' to a Module as this -- is how the data is stored in the Modules table. A 'Module' carries a BlobRef to the source -- but that reference should never be consulted in the scope of Instance operations. -- Invariant: the module will always be of the appropriate version. - pinstanceModuleInterface :: !(HashedCachedRef Modules.ModuleCache Modules.Module), + pinstanceModuleInterface :: !(HashedCachedRef store (Modules.ModuleCache store) (Modules.Module store)), -- | The current local state of the instance - pinstanceModel :: !(InstanceStateV v), + pinstanceModel :: !(InstanceStateV store v), -- | The current amount of GTU owned by the instance pinstanceAmount :: !Amount, -- | Hash of the smart contract instance @@ -136,9 +136,9 @@ migratePersistentInstanceV :: MonadTrans t ) => -- | The already migrated modules. - Modules.Modules -> - PersistentInstanceV v -> - t m (PersistentInstanceV v) + Modules.Modules (MBSStore (t m)) -> + PersistentInstanceV (MBSStore m) v -> + t m (PersistentInstanceV (MBSStore (t m)) v) migratePersistentInstanceV modules PersistentInstanceV{..} = do newInstanceParameters <- migrateReference return pinstanceParameters params <- loadBufferedRef newInstanceParameters @@ -175,9 +175,9 @@ migratePersistentInstanceV modules PersistentInstanceV{..} = do -- in the instance table, as opposed to having multiple instance tables for -- different instance versions. This is necessary because there is a single -- address space for all contract instances. -data PersistentInstance (pv :: ProtocolVersion) where - PersistentInstanceV0 :: !(PersistentInstanceV GSWasm.V0) -> PersistentInstance pv - PersistentInstanceV1 :: !(PersistentInstanceV GSWasm.V1) -> PersistentInstance pv +data PersistentInstance store (pv :: ProtocolVersion) where + PersistentInstanceV0 :: !(PersistentInstanceV store GSWasm.V0) -> PersistentInstance store pv + PersistentInstanceV1 :: !(PersistentInstanceV store GSWasm.V1) -> PersistentInstance store pv -- | Migrate persistent instances from the old to the new protocol version. migratePersistentInstance :: @@ -187,29 +187,36 @@ migratePersistentInstance :: -- module migration, so we want to insert references to the existing modules -- in the instances so that we don't end up with duplicates both in-memory -- and on disk. - Modules.Modules -> - PersistentInstance oldpv -> - t m (PersistentInstance pv) + Modules.Modules (MBSStore (t m)) -> + PersistentInstance (MBSStore m) oldpv -> + t m (PersistentInstance (MBSStore (t m)) pv) migratePersistentInstance modules (PersistentInstanceV0 p) = PersistentInstanceV0 <$> migratePersistentInstanceV modules p migratePersistentInstance modules (PersistentInstanceV1 p) = PersistentInstanceV1 <$> migratePersistentInstanceV modules p -instance Show (PersistentInstance pv) where +instance Show (PersistentInstance store pv) where show (PersistentInstanceV0 PersistentInstanceV{pinstanceModel = InstanceStateV0 model, ..}) = show pinstanceParameters ++ " {balance=" ++ show pinstanceAmount ++ ", model=" ++ show model ++ "}" show (PersistentInstanceV1 PersistentInstanceV{..}) = show pinstanceParameters ++ " {balance=" ++ show pinstanceAmount ++ "}" -loadInstanceParameters :: (MonadBlobStore m) => PersistentInstance pv -> m PersistentInstanceParameters +loadInstanceParameters :: + (MonadBlobStore m) => + PersistentInstance (MBSStore m) pv -> m PersistentInstanceParameters loadInstanceParameters (PersistentInstanceV0 PersistentInstanceV{..}) = loadBufferedRef pinstanceParameters loadInstanceParameters (PersistentInstanceV1 PersistentInstanceV{..}) = loadBufferedRef pinstanceParameters -cacheInstanceParameters :: (MonadBlobStore m) => PersistentInstance pv -> m (PersistentInstanceParameters, BufferedRef PersistentInstanceParameters) +cacheInstanceParameters :: + (MonadBlobStore m) => + PersistentInstance (MBSStore m) pv -> + m (PersistentInstanceParameters, BufferedRef (MBSStore m) PersistentInstanceParameters) cacheInstanceParameters (PersistentInstanceV0 PersistentInstanceV{..}) = cacheBufferedRef pinstanceParameters cacheInstanceParameters (PersistentInstanceV1 PersistentInstanceV{..}) = cacheBufferedRef pinstanceParameters -loadInstanceModule :: (MonadProtocolVersion m, SupportsPersistentModule m) => PersistentInstance pv -> m Module +loadInstanceModule :: + (MonadProtocolVersion m, SupportsPersistentModule m) => + PersistentInstance (MBSStore m) pv -> m (Module (MBSStore m)) loadInstanceModule (PersistentInstanceV0 PersistentInstanceV{..}) = refLoad pinstanceModuleInterface loadInstanceModule (PersistentInstanceV1 PersistentInstanceV{..}) = refLoad pinstanceModuleInterface -instance HashableTo H.Hash (PersistentInstance pv) where +instance HashableTo H.Hash (PersistentInstance store pv) where getHash (PersistentInstanceV0 PersistentInstanceV{..}) = pinstanceHash getHash (PersistentInstanceV1 PersistentInstanceV{..}) = pinstanceHash @@ -218,7 +225,10 @@ instance HashableTo H.Hash (PersistentInstance pv) where -- decide whether we are loading instance V0 or instance V1, we essentially have -- two implementations of BlobStorable. One for protocol versions <= P3, and -- another one for later protocol versions. The latter ones add versioning information. -instance (IsProtocolVersion pv, MonadProtocolVersion m, SupportsPersistentModule m, MPV m ~ pv) => BlobStorable m (PersistentInstance pv) where +instance + (IsProtocolVersion pv, MonadProtocolVersion m, SupportsPersistentModule m, MPV m ~ pv, store ~ MBSStore m) => + BlobStorable m (PersistentInstance store pv) + where storeUpdate inst = do if demoteProtocolVersion (protocolVersion @pv) <= P3 then case inst of @@ -228,7 +238,8 @@ instance (IsProtocolVersion pv, MonadProtocolVersion m, SupportsPersistentModule PersistentInstanceV0 i -> addVersion <$> storeUnversionedV0 i PersistentInstanceV1 i -> storeV1 i where - storeUnversionedV0 :: PersistentInstanceV GSWasm.V0 -> m (Put, PersistentInstanceV GSWasm.V0) + storeUnversionedV0 :: + PersistentInstanceV store GSWasm.V0 -> m (Put, PersistentInstanceV store GSWasm.V0) storeUnversionedV0 PersistentInstanceV{pinstanceModel = InstanceStateV0 model, ..} = do (pparams, newParameters) <- storeUpdate pinstanceParameters (pinterface, newpInterface) <- storeUpdate pinstanceModuleInterface @@ -246,7 +257,7 @@ instance (IsProtocolVersion pv, MonadProtocolVersion m, SupportsPersistentModule .. } ) - storeV1 :: PersistentInstanceV GSWasm.V1 -> m (Put, PersistentInstance pv) + storeV1 :: PersistentInstanceV store GSWasm.V1 -> m (Put, PersistentInstance store pv) storeV1 PersistentInstanceV{pinstanceModel = InstanceStateV1 model, ..} = do (pparams, newParameters) <- storeUpdate pinstanceParameters (pinterface, newpInterface) <- storeUpdate pinstanceModuleInterface @@ -305,12 +316,15 @@ instance (IsProtocolVersion pv, MonadProtocolVersion m, SupportsPersistentModule pinstanceHash <- makeInstanceHashV1State (pinstanceParameterHash pip) pinstanceModel pinstanceAmount return $! PersistentInstanceV1 (PersistentInstanceV{..}) -instance (MonadBlobStore m) => Cacheable m (InstanceStateV GSWasm.V1) where +instance (MonadBlobStore m) => Cacheable m (InstanceStateV store GSWasm.V1) where cache (InstanceStateV1 model) = InstanceStateV1 <$> cache model -- This cacheable instance is a bit unusual. Caching instances requires us to have access -- to the modules so that we can share the module interfaces from different instances. -instance (MonadProtocolVersion m, SupportsPersistentModule m) => Cacheable (ReaderT Modules m) (PersistentInstance pv) where +instance + (MonadProtocolVersion m, SupportsPersistentModule m, store ~ MBSStore m) => + Cacheable (ReaderT (Modules store) m) (PersistentInstance store pv) + where cache (PersistentInstanceV0 p@PersistentInstanceV{..}) = do modules <- ask lift $! do @@ -345,11 +359,17 @@ instance (MonadProtocolVersion m, SupportsPersistentModule m) => Cacheable (Read -- | Construct instance information from a persistent instance, loading as much -- data as necessary from persistent storage. -mkInstanceInfo :: (MonadProtocolVersion m, SupportsPersistentModule m) => PersistentInstance pv -> m (InstanceInfoType PersistentInstrumentedModuleV InstanceStateV) +mkInstanceInfo :: + (MonadProtocolVersion m, SupportsPersistentModule m) => + PersistentInstance (MBSStore m) pv -> + m (InstanceInfoType (PersistentInstrumentedModuleV (MBSStore m)) (InstanceStateV (MBSStore m))) mkInstanceInfo (PersistentInstanceV0 inst) = InstanceInfoV0 <$> mkInstanceInfoV inst mkInstanceInfo (PersistentInstanceV1 inst) = InstanceInfoV1 <$> mkInstanceInfoV inst -mkInstanceInfoV :: (MonadProtocolVersion m, SupportsPersistentModule m, Wasm.IsWasmVersion v) => PersistentInstanceV v -> m (InstanceInfoTypeV PersistentInstrumentedModuleV InstanceStateV v) +mkInstanceInfoV :: + (MonadProtocolVersion m, SupportsPersistentModule m, Wasm.IsWasmVersion v) => + PersistentInstanceV (MBSStore m) v -> + m (InstanceInfoTypeV (PersistentInstrumentedModuleV (MBSStore m)) (InstanceStateV (MBSStore m)) v) mkInstanceInfoV PersistentInstanceV{..} = do PersistentInstanceParameters{..} <- loadBufferedRef pinstanceParameters instanceModuleInterface <- moduleVInterface . unsafeToModuleV <$> refLoad pinstanceModuleInterface @@ -386,7 +406,7 @@ makeInstanceParameterHash ca aa modRef conName = H.hashLazy $ runPutLazy $ do put modRef put conName -makeInstanceHashV0State :: InstanceParametersHash -> InstanceStateV GSWasm.V0 -> Amount -> InstanceHash +makeInstanceHashV0State :: InstanceParametersHash -> InstanceStateV store GSWasm.V0 -> Amount -> InstanceHash makeInstanceHashV0State paramsHash (InstanceStateV0 conState) = makeInstanceHashV0 paramsHash (getHash conState) makeInstanceHashV0 :: InstanceParametersHash -> InstanceStateHash -> Amount -> InstanceHash @@ -395,7 +415,9 @@ makeInstanceHashV0 paramsHash csHash a = H.hash $ runPut $ do put csHash put a -makeInstanceHashV1State :: (MonadBlobStore m) => InstanceParametersHash -> InstanceStateV GSWasm.V1 -> Amount -> m InstanceHash +makeInstanceHashV1State :: + (MonadBlobStore m) => + InstanceParametersHash -> InstanceStateV (MBSStore m) GSWasm.V1 -> Amount -> m InstanceHash makeInstanceHashV1State paramsHash (InstanceStateV1 conState) a = do csHash <- getHashM conState return $! makeInstanceHashV1 paramsHash csHash a @@ -417,7 +439,7 @@ makeBranchHash h1 h2 = H.hashShort $! (H.hashToShortByteString h1 <> H.hashToSho -- * The hash is @computeBranchHash l r@ where @l@ and @r@ are the left and right subtrees -- * The first @Bool@ is @True@ if the tree is full, i.e. the right sub-tree is full with height 1 less than the parent -- * The second @Bool@ is @True@ if the either subtree has vacant leaves -data IT pv r +data IT store pv r = -- | A branch has the following fields: -- * the height of the branch (0 if all children are leaves) -- * whether the branch is a full binary tree @@ -433,31 +455,31 @@ data IT pv r branchRight :: r } | -- | A leaf holds a contract instance - Leaf !(PersistentInstance pv) + Leaf !(PersistentInstance store pv) | -- | A vacant leaf records the 'ContractSubindex' of the last instance -- with this 'ContractIndex'. VacantLeaf !ContractSubindex deriving (Show, Functor, Foldable, Traversable) -showITString :: IT pv String -> String +showITString :: IT store pv String -> String showITString (Branch h _ _ _ l r) = show h ++ ":(" ++ l ++ ", " ++ r ++ ")" showITString (Leaf i) = show i showITString (VacantLeaf si) = "[Vacant " ++ show si ++ "]" -hasVacancies :: IT pv r -> Bool +hasVacancies :: IT store pv r -> Bool hasVacancies Branch{..} = branchHasVacancies hasVacancies Leaf{} = False hasVacancies VacantLeaf{} = True -isFull :: IT pv r -> Bool +isFull :: IT store pv r -> Bool isFull Branch{..} = branchFull isFull _ = True -nextHeight :: IT pv r -> Word8 +nextHeight :: IT store pv r -> Word8 nextHeight Branch{..} = branchHeight + 1 nextHeight _ = 0 -instance HashableTo H.Hash (IT pv r) where +instance HashableTo H.Hash (IT store pv r) where getHash (Branch{..}) = branchHash getHash (Leaf i) = getHash i getHash (VacantLeaf si) = H.hash $ runPut $ put si @@ -466,7 +488,18 @@ conditionalSetBit :: (Bits a) => Int -> Bool -> a -> a conditionalSetBit _ False x = x conditionalSetBit b True x = setBit x b -instance (MonadLogger m, MonadProtocolVersion m, IsProtocolVersion pv, MPV m ~ pv, BlobStorable m r, Cache.MonadCache ModuleCache m, MonadModuleMapStore m) => BlobStorable m (IT pv r) where +instance + ( MonadLogger m, + MonadProtocolVersion m, + IsProtocolVersion pv, + MPV m ~ pv, + BlobStorable m r, + Cache.MonadCache (ModuleCache store) m, + MonadModuleMapStore m, + store ~ MBSStore m + ) => + BlobStorable m (IT store pv r) + where storeUpdate (Branch{..}) = do (pl, l') <- storeUpdate branchLeft (pr, r') <- storeUpdate branchRight @@ -504,24 +537,30 @@ instance (MonadLogger m, MonadProtocolVersion m, IsProtocolVersion pv, MPV m ~ p -- leaf. The accumulator is called with @Left addr@ when the leaf is vacant, -- i.e. the instance on that address was deleted. It is called with @Right inst@ -- when there is an instance in the spot. -mapReduceIT :: forall a m pv t. (Monoid a, MRecursive m t, Base t ~ IT pv) => (Either ContractAddress (PersistentInstance pv) -> m a) -> t -> m a +mapReduceIT :: + forall a m store pv t. + (Monoid a, MRecursive m t, Base t ~ IT store pv) => + (Either ContractAddress (PersistentInstance store pv) -> m a) -> t -> m a mapReduceIT mfun = mr 0 <=< mproject where - mr :: ContractIndex -> IT pv t -> m a + mr :: ContractIndex -> IT store pv t -> m a mr lowIndex (Branch hgt _ _ _ l r) = liftM2 (<>) (mr lowIndex =<< mproject l) (mr (setBit lowIndex (fromIntegral hgt)) =<< mproject r) mr _ (Leaf i) = mfun (Right i) mr lowIndex (VacantLeaf si) = mfun (Left (ContractAddress lowIndex si)) -makeBranch :: Word8 -> Bool -> IT pv t -> IT pv t -> t -> t -> IT pv t +makeBranch :: Word8 -> Bool -> IT store pv t -> IT store pv t -> t -> t -> IT store pv t makeBranch branchHeight branchFull l r branchLeft branchRight = Branch{..} where branchHasVacancies = hasVacancies l || hasVacancies r branchHash = makeBranchHash (getHash l) (getHash r) -newContractInstanceIT :: forall m pv t a. (MRecursive m t, MCorecursive m t, Base t ~ IT pv) => (ContractAddress -> m (a, PersistentInstance pv)) -> t -> m (a, t) +newContractInstanceIT :: + forall m store pv t a. + (MRecursive m t, MCorecursive m t, Base t ~ IT store pv) => + (ContractAddress -> m (a, PersistentInstance store pv)) -> t -> m (a, t) newContractInstanceIT mk t0 = (\(res, v) -> (res,) <$> membed v) =<< nci 0 t0 =<< mproject t0 where - nci :: ContractIndex -> t -> IT pv t -> m (a, IT pv t) + nci :: ContractIndex -> t -> IT store pv t -> m (a, IT store pv t) -- Insert into a tree with vacancies: insert in left if it has vacancies, otherwise right nci offset _ (Branch h f True _ l r) = do projl <- mproject l @@ -570,12 +609,14 @@ migrateIT :: IsProtocolVersion oldpv, IsProtocolVersion pv ) => - Modules.Modules -> - BufferedFix (IT oldpv) -> - t m (BufferedFix (IT pv)) + Modules.Modules (MBSStore (t m)) -> + BufferedFix (MBSStore m) (IT (MBSStore m) oldpv) -> + t m (BufferedFix (MBSStore (t m)) (IT (MBSStore (t m)) pv)) migrateIT modules (BufferedFix bf) = BufferedFix <$> migrateReference go bf where - go :: IT oldpv (BufferedFix (IT oldpv)) -> t m (IT pv (BufferedFix (IT pv))) + go :: + IT (MBSStore m) oldpv (BufferedFix (MBSStore m) (IT (MBSStore m) oldpv)) -> + t m (IT (MBSStore (t m)) pv (BufferedFix (MBSStore (t m)) (IT (MBSStore (t m)) pv))) go Branch{..} = do newLeft <- migrateIT modules branchLeft newRight <- migrateIT modules branchRight @@ -588,11 +629,11 @@ migrateIT modules (BufferedFix bf) = BufferedFix <$> migrateReference go bf go (Leaf pinst) = Leaf <$> migratePersistentInstance modules pinst go (VacantLeaf i) = return (VacantLeaf i) -data Instances pv +data Instances store pv = -- | The empty instance table InstancesEmpty | -- | A non-empty instance table, recording the number of leaf nodes, including vacancies - InstancesTree !Word64 !(BufferedFix (IT pv)) + InstancesTree !Word64 !(BufferedFix store (IT store pv)) migrateInstances :: ( SupportMigration m t, @@ -605,15 +646,15 @@ migrateInstances :: IsProtocolVersion oldpv, IsProtocolVersion pv ) => - Modules.Modules -> - Instances oldpv -> - t m (Instances pv) + Modules.Modules (MBSStore (t m)) -> + Instances (MBSStore m) oldpv -> + t m (Instances (MBSStore (t m)) pv) migrateInstances _ InstancesEmpty = return InstancesEmpty migrateInstances modules (InstancesTree size bf) = do newBF <- migrateIT modules bf return $! InstancesTree size newBF -instance Show (Instances pv) where +instance Show (Instances store pv) where show InstancesEmpty = "Empty" show (InstancesTree _ t) = showFix showITString t @@ -629,13 +670,26 @@ makeInstancesHash size inner = case sBlockHashVersionFor (protocolVersion @pv) o put inner instance - (IsProtocolVersion pv, MonadProtocolVersion m, MPV m ~ pv, SupportsPersistentModule m) => - MHashableTo m (InstancesHash pv) (Instances pv) + ( IsProtocolVersion pv, + MonadProtocolVersion m, + MPV m ~ pv, + SupportsPersistentModule m, + store ~ MBSStore m + ) => + MHashableTo m (InstancesHash pv) (Instances store pv) where getHashM InstancesEmpty = return $ makeInstancesHash 0 $ H.hash "EmptyInstances" getHashM (InstancesTree size t) = makeInstancesHash size . getHash <$> mproject t -instance (IsProtocolVersion pv, MonadProtocolVersion m, MPV m ~ pv, SupportsPersistentModule m) => BlobStorable m (Instances pv) where +instance + ( IsProtocolVersion pv, + MonadProtocolVersion m, + MPV m ~ pv, + SupportsPersistentModule m, + store ~ MBSStore m + ) => + BlobStorable m (Instances store pv) + where storeUpdate i@InstancesEmpty = return (putWord8 0, i) storeUpdate (InstancesTree s t) = do (pt, t') <- storeUpdate t @@ -648,7 +702,10 @@ instance (IsProtocolVersion pv, MonadProtocolVersion m, MPV m ~ pv, SupportsPers s <- get fmap (InstancesTree s) <$> load -instance (MonadBlobStore m, Cacheable m r, Cacheable m (PersistentInstance pv)) => Cacheable m (IT pv r) where +instance + (MonadBlobStore m, Cacheable m r, Cacheable m (PersistentInstance store pv)) => + Cacheable m (IT store pv r) + where cache Branch{..} = do branchLeft' <- cache branchLeft branchRight' <- cache branchRight @@ -656,14 +713,25 @@ instance (MonadBlobStore m, Cacheable m r, Cacheable m (PersistentInstance pv)) cache (Leaf l) = Leaf <$> cache l cache vacant = return vacant -instance (IsProtocolVersion pv, MonadProtocolVersion m, MPV m ~ pv, SupportsPersistentModule m) => Cacheable (ReaderT Modules m) (Instances pv) where +instance + ( IsProtocolVersion pv, + MonadProtocolVersion m, + MPV m ~ pv, + SupportsPersistentModule m, + store ~ MBSStore m + ) => + Cacheable (ReaderT (Modules store) m) (Instances store pv) + where cache i@InstancesEmpty = return i cache (InstancesTree s r) = InstancesTree s <$> cache r -emptyInstances :: Instances pv +emptyInstances :: Instances store pv emptyInstances = InstancesEmpty -newContractInstance :: forall m pv a. (IsProtocolVersion pv, MonadProtocolVersion m, MPV m ~ pv, SupportsPersistentModule m) => (ContractAddress -> m (a, PersistentInstance pv)) -> Instances pv -> m (a, Instances pv) +newContractInstance :: + forall m pv a. + (IsProtocolVersion pv, MonadProtocolVersion m, MPV m ~ pv, SupportsPersistentModule m) => + (ContractAddress -> m (a, PersistentInstance (MBSStore m) pv)) -> Instances (MBSStore m) pv -> m (a, Instances (MBSStore m) pv) newContractInstance createInstanceFn InstancesEmpty = do let ca = ContractAddress 0 0 (res, newInst) <- createInstanceFn ca @@ -680,7 +748,10 @@ newContractInstance createInstanceFn (InstancesTree size tree) = do -- Otherwise, a vacancy is filled, and the size does not grow. return ((contractSubindex newContractAddress == 0, result), createdInstance) -deleteContractInstance :: forall m pv. (IsProtocolVersion pv, MonadProtocolVersion m, MPV m ~ pv, SupportsPersistentModule m) => ContractAddress -> Instances pv -> m (Instances pv) +deleteContractInstance :: + forall m pv. + (IsProtocolVersion pv, MonadProtocolVersion m, MPV m ~ pv, SupportsPersistentModule m) => + ContractAddress -> Instances (MBSStore m) pv -> m (Instances (MBSStore m) pv) deleteContractInstance _ InstancesEmpty = return InstancesEmpty deleteContractInstance addr t0@(InstancesTree s it0) = dci (fmap (InstancesTree s) . membed) (contractIndex addr) =<< mproject it0 where @@ -707,7 +778,10 @@ deleteContractInstance addr t0@(InstancesTree s it0) = dci (fmap (InstancesTree in dci newCont (i - 2 ^ h) =<< mproject r | otherwise = return t0 -lookupContractInstance :: forall m pv. (IsProtocolVersion pv, MonadProtocolVersion m, MPV m ~ pv, SupportsPersistentModule m) => ContractAddress -> Instances pv -> m (Maybe (PersistentInstance pv)) +lookupContractInstance :: + forall m pv. + (IsProtocolVersion pv, MonadProtocolVersion m, MPV m ~ pv, SupportsPersistentModule m) => + ContractAddress -> Instances (MBSStore m) pv -> m (Maybe (PersistentInstance (MBSStore m) pv)) lookupContractInstance _ InstancesEmpty = return Nothing lookupContractInstance addr (InstancesTree _ it0) = lu (contractIndex addr) =<< mproject it0 where @@ -722,7 +796,13 @@ lookupContractInstance addr (InstancesTree _ it0) = lu (contractIndex addr) =<< | i < 2 ^ (h + 1) = lu (i - 2 ^ h) =<< mproject r | otherwise = return Nothing -updateContractInstance :: forall m pv a. (IsProtocolVersion pv, MonadProtocolVersion m, MPV m ~ pv, SupportsPersistentModule m) => (PersistentInstance pv -> m (a, PersistentInstance pv)) -> ContractAddress -> Instances pv -> m (Maybe (a, Instances pv)) +updateContractInstance :: + forall m pv a. + (IsProtocolVersion pv, MonadProtocolVersion m, MPV m ~ pv, SupportsPersistentModule m) => + (PersistentInstance (MBSStore m) pv -> m (a, PersistentInstance (MBSStore m) pv)) -> + ContractAddress -> + Instances (MBSStore m) pv -> + m (Maybe (a, Instances (MBSStore m) pv)) updateContractInstance _ _ InstancesEmpty = return Nothing updateContractInstance fupd addr (InstancesTree s it0) = upd baseSuccess (contractIndex addr) =<< mproject it0 where @@ -755,7 +835,10 @@ updateContractInstance fupd addr (InstancesTree s it0) = upd baseSuccess (contra | otherwise = return Nothing -- | Retrieve the list of all instance addresses. The addresses are returned in increasing order. -allInstances :: forall m pv. (IsProtocolVersion pv, MonadProtocolVersion m, MPV m ~ pv, SupportsPersistentModule m) => Instances pv -> m [ContractAddress] +allInstances :: + forall m pv. + (IsProtocolVersion pv, MonadProtocolVersion m, MPV m ~ pv, SupportsPersistentModule m) => + Instances (MBSStore m) pv -> m [ContractAddress] allInstances InstancesEmpty = return [] allInstances (InstancesTree _ it) = mapReduceIT mfun it where diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/PoolRewards.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/PoolRewards.hs index c6f5437217..390af56737 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/PoolRewards.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/PoolRewards.hs @@ -100,8 +100,8 @@ migratePoolRewardsP6 :: Epoch -> -- | The length of the reward period. RewardPeriodLength -> - PoolRewards bhv0 av0 -> - t m (PoolRewards bhv1 av1) + PoolRewards (MBSStore m) bhv0 av0 -> + t m (PoolRewards (MBSStore (t m)) bhv1 av1) migratePoolRewardsP6 oldEpoch rpLength pr = migratePoolRewards newNextPayday pr where oldPaydayEpoch = nextPaydayEpoch pr @@ -281,7 +281,7 @@ bakerBlockCounts PoolRewards{..} = do -- missed rounds are carried over from the old pool rewards. rotateCapitalDistribution :: forall av ref m bhv. - ( MonadBlobStore m, + ( MonadBlobStore m, Reference m (MBSStore m) ref (PoolRewards (MBSStore m) bhv av), IsBlockHashVersion bhv, IsAccountVersion av diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/ReleaseSchedule.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/ReleaseSchedule.hs index 5f9f8bbe3d..1495e5f278 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/ReleaseSchedule.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/ReleaseSchedule.hs @@ -83,8 +83,11 @@ instance Serialize LegacyReleaseSchedule where instance (MonadBlobStore m) => BlobStorable m LegacyReleaseSchedule instance (Applicative m) => Cacheable m LegacyReleaseSchedule -instance (MonadBlobStore m) => ReleaseScheduleOperations m (BufferedRef LegacyReleaseSchedule) where - type AccountRef (BufferedRef LegacyReleaseSchedule) = AccountAddress +instance + (MonadBlobStore m, store ~ MBSStore m) => + ReleaseScheduleOperations m (BufferedRef store LegacyReleaseSchedule) + where + type AccountRef (BufferedRef store LegacyReleaseSchedule) = AccountAddress addAccountRelease ts addr br = do LegacyReleaseSchedule{..} <- refLoad br @@ -144,7 +147,7 @@ instance (Applicative m) => Cacheable m AccountSet -- | A release schedule for the P5 protocol version. This uses a 'Trie.Trie' mapping 'Timestamp's -- to sets of accounts. -data NewReleaseSchedule = NewReleaseSchedule +data NewReleaseSchedule store = NewReleaseSchedule { -- | The first timestamp at which a release is scheduled (or the maximum possible timestamp if -- no releases are scheduled). This MUST NOT be used to infer that the release schedule is -- empty, since there can be a release at the maximum timestamp. @@ -155,11 +158,11 @@ data NewReleaseSchedule = NewReleaseSchedule -- Timestamp which is the natural ordering due to big-endian -- serialization. This allows us to also use the Trie to find the release -- with minimal timestamp. - nrsMap :: !(Trie.TrieN BufferedFix Timestamp AccountSet) + nrsMap :: !(Trie.TrieN (BufferedFix store) Timestamp AccountSet) } deriving (Show) -instance (MonadBlobStore m) => BlobStorable m NewReleaseSchedule where +instance (MonadBlobStore m, store ~ MBSStore m) => BlobStorable m (NewReleaseSchedule store) where storeUpdate NewReleaseSchedule{..} = do (pmap, newMap) <- storeUpdate nrsMap let !p = do @@ -174,13 +177,16 @@ instance (MonadBlobStore m) => BlobStorable m NewReleaseSchedule where nrsMap <- mmap return $! NewReleaseSchedule{..} -instance (MonadBlobStore m) => Cacheable m NewReleaseSchedule where +instance (MonadBlobStore m, store ~ MBSStore m) => Cacheable m (NewReleaseSchedule store) where cache rs = do newMap <- cache (nrsMap rs) return $! rs{nrsMap = newMap} -instance (MonadBlobStore m) => ReleaseScheduleOperations m NewReleaseSchedule where - type AccountRef NewReleaseSchedule = AccountIndex +instance + (MonadBlobStore m, store ~ MBSStore m) => + ReleaseScheduleOperations m (NewReleaseSchedule store) + where + type AccountRef (NewReleaseSchedule store) = AccountIndex addAccountRelease ts ai rs = do (_, nrsMap) <- Trie.adjust addAcc ts (nrsMap rs) @@ -225,7 +231,7 @@ instance (MonadBlobStore m) => ReleaseScheduleOperations m NewReleaseSchedule wh go (accum ++ Set.toList (theAccountSet accs)) newMap -- | A release schedule with no entries. -emptyNewReleaseSchedule :: NewReleaseSchedule +emptyNewReleaseSchedule :: NewReleaseSchedule store emptyNewReleaseSchedule = NewReleaseSchedule { nrsFirstTimestamp = Timestamp maxBound, @@ -233,7 +239,10 @@ emptyNewReleaseSchedule = } -- | Migrate a 'NewReleaseSchedule' from one 'BlobStore' to another. -migrateNewReleaseSchedule :: (SupportMigration m t) => NewReleaseSchedule -> t m NewReleaseSchedule +migrateNewReleaseSchedule :: + (SupportMigration m t) => + NewReleaseSchedule (MBSStore m) -> + t m (NewReleaseSchedule (MBSStore (t m))) migrateNewReleaseSchedule rs = do newMap <- Trie.migrateTrieN True return (nrsMap rs) return $! @@ -252,8 +261,8 @@ removeAccountFromReleaseSchedule :: -- | The account index to remove. AccountIndex -> -- | The release schedule to remove the account from. - NewReleaseSchedule -> - m NewReleaseSchedule + NewReleaseSchedule (MBSStore m) -> + m (NewReleaseSchedule (MBSStore m)) removeAccountFromReleaseSchedule ts ai rs = do (_, nrsMap) <- Trie.adjust remAcc ts (nrsMap rs) newMin <- Trie.findMin nrsMap @@ -283,21 +292,24 @@ type family RSAccountRef pv where RSAccountRef _ = AccountIndex -- | A top-level release schedule used for a particular protocol version. -data ReleaseSchedule (pv :: ProtocolVersion) where +data ReleaseSchedule store (pv :: ProtocolVersion) where -- | A release schedule for protocol versions 'P1' to 'P4'. ReleaseScheduleP0 :: (RSAccountRef pv ~ AccountAddress) => - !(BufferedRef LegacyReleaseSchedule) -> - ReleaseSchedule pv + !(BufferedRef store LegacyReleaseSchedule) -> + ReleaseSchedule store pv -- | A release schedule for protocol versions 'P5' onwards. ReleaseScheduleP5 :: (RSAccountRef pv ~ AccountIndex) => - !NewReleaseSchedule -> - ReleaseSchedule pv + !(NewReleaseSchedule store) -> + ReleaseSchedule store pv -deriving instance (IsProtocolVersion pv) => Show (ReleaseSchedule pv) +deriving instance (IsProtocolVersion pv) => Show (ReleaseSchedule store pv) -instance (MonadBlobStore m, IsProtocolVersion pv) => BlobStorable m (ReleaseSchedule pv) where +instance + (MonadBlobStore m, IsProtocolVersion pv, store ~ MBSStore m) => + BlobStorable m (ReleaseSchedule store pv) + where storeUpdate (ReleaseScheduleP0 rs) = second ReleaseScheduleP0 <$> storeUpdate rs storeUpdate (ReleaseScheduleP5 rs) = second ReleaseScheduleP5 <$> storeUpdate rs load = case protocolVersion @pv of @@ -312,12 +324,15 @@ instance (MonadBlobStore m, IsProtocolVersion pv) => BlobStorable m (ReleaseSche SP9 -> fmap ReleaseScheduleP5 <$> load SP10 -> fmap ReleaseScheduleP5 <$> load -instance (MonadBlobStore m) => Cacheable m (ReleaseSchedule pv) where +instance (MonadBlobStore m, store ~ MBSStore m) => Cacheable m (ReleaseSchedule store pv) where cache (ReleaseScheduleP0 rs) = ReleaseScheduleP0 <$> cache rs cache (ReleaseScheduleP5 rs) = ReleaseScheduleP5 <$> cache rs -instance (MonadBlobStore m) => ReleaseScheduleOperations m (ReleaseSchedule pv) where - type AccountRef (ReleaseSchedule pv) = RSAccountRef pv +instance + (MonadBlobStore m, store ~ MBSStore m) => + ReleaseScheduleOperations m (ReleaseSchedule store pv) + where + type AccountRef (ReleaseSchedule store pv) = RSAccountRef pv addAccountRelease ts addr (ReleaseScheduleP0 rs) = ReleaseScheduleP0 <$!> addAccountRelease ts addr rs addAccountRelease ts addr (ReleaseScheduleP5 rs) = @@ -332,7 +347,10 @@ instance (MonadBlobStore m) => ReleaseScheduleOperations m (ReleaseSchedule pv) second ReleaseScheduleP5 <$!> processReleasesUntil ts rs -- | Construct an empty release schedule. -emptyReleaseSchedule :: forall m pv. (IsProtocolVersion pv, MonadBlobStore m) => m (ReleaseSchedule pv) +emptyReleaseSchedule :: + forall m pv. + (IsProtocolVersion pv, MonadBlobStore m) => + m (ReleaseSchedule (MBSStore m) pv) emptyReleaseSchedule = case protocolVersion @pv of SP1 -> rsP0 SP2 -> rsP0 @@ -345,7 +363,7 @@ emptyReleaseSchedule = case protocolVersion @pv of SP9 -> rsP1 SP10 -> rsP1 where - rsP0 :: (RSAccountRef pv ~ AccountAddress) => m (ReleaseSchedule pv) + rsP0 :: (RSAccountRef pv ~ AccountAddress) => m (ReleaseSchedule (MBSStore m) pv) rsP0 = do rsRef <- refMake $! @@ -355,7 +373,7 @@ emptyReleaseSchedule = case protocolVersion @pv of lrsEntryCount = 0 } return $! ReleaseScheduleP0 rsRef - rsP1 :: (RSAccountRef pv ~ AccountIndex) => m (ReleaseSchedule pv) + rsP1 :: (RSAccountRef pv ~ AccountIndex) => m (ReleaseSchedule (MBSStore m) pv) rsP1 = do return $! ReleaseScheduleP5 @@ -400,8 +418,8 @@ trivialReleaseScheduleMigration = case protocolVersion @pv of migrateReleaseSchedule :: (SupportMigration m t) => ReleaseScheduleMigration m oldpv pv -> - ReleaseSchedule oldpv -> - t m (ReleaseSchedule pv) + ReleaseSchedule (MBSStore m) oldpv -> + t m (ReleaseSchedule (MBSStore (t m)) pv) migrateReleaseSchedule RSMLegacyToLegacy (ReleaseScheduleP0 rs) = ReleaseScheduleP0 <$!> migrateReference return rs migrateReleaseSchedule (RSMLegacyToNew resolveAcc) (ReleaseScheduleP0 rsRef) = do @@ -427,14 +445,14 @@ migrateReleaseSchedule RSMNewToNew (ReleaseScheduleP5 rs) = do releasesMap :: (MonadBlobStore m) => (AccountAddress -> m AccountIndex) -> - ReleaseSchedule pv -> + ReleaseSchedule (MBSStore m) pv -> m (Map.Map Timestamp (Set.Set AccountIndex)) releasesMap resolveAddr (ReleaseScheduleP0 rsRef) = do LegacyReleaseSchedule{..} <- refLoad rsRef forM lrsMap $ fmap Set.fromList . mapM resolveAddr . Set.toList releasesMap _ (ReleaseScheduleP5 rs) = newReleasesMap rs -newReleasesMap :: (MonadBlobStore m) => NewReleaseSchedule -> m (Map Timestamp (Set AccountIndex)) +newReleasesMap :: (MonadBlobStore m) => NewReleaseSchedule (MBSStore m) -> m (Map Timestamp (Set AccountIndex)) newReleasesMap rs = do m <- Trie.toMap (nrsMap rs) return (theAccountSet <$> m) diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/TreeState.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/TreeState.hs index f702ccc302..d3a34b0081 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/TreeState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/TreeState.hs @@ -204,25 +204,25 @@ emptyBlockTable = BlockTable emptyDeadCache HM.empty -- The first type parameter, @pv@, is the protocol version. -- The second type parameter, @ati@, is a type determining the account transaction index to use. -- The third type parameter, @bs@, is the type of block states. -data SkovPersistentData (pv :: ProtocolVersion) = SkovPersistentData +data SkovPersistentData store (pv :: ProtocolVersion) = SkovPersistentData { -- | Map of all received blocks by hash. - _blockTable :: !(BlockTable pv (PBS.HashedPersistentBlockState pv)), + _blockTable :: !(BlockTable pv (PBS.HashedPersistentBlockState store pv)), -- | Map of (possibly) pending blocks by hash _possiblyPendingTable :: !(HM.HashMap BlockHash [PendingBlock]), -- | Priority queue of pairs of (block, parent) hashes where the block is (possibly) pending its parent, by block slot _possiblyPendingQueue :: !(MPQ.MinPQueue Slot (BlockHash, BlockHash)), -- | Pointer to the last finalized block - _lastFinalized :: !(PersistentBlockPointer pv (PBS.HashedPersistentBlockState pv)), + _lastFinalized :: !(PersistentBlockPointer pv (PBS.HashedPersistentBlockState store pv)), -- | Pointer to the last finalization record _lastFinalizationRecord :: !FinalizationRecord, -- | Branches of the tree by height above the last finalized block - _branches :: !(Seq.Seq [PersistentBlockPointer pv (PBS.HashedPersistentBlockState pv)]), + _branches :: !(Seq.Seq [PersistentBlockPointer pv (PBS.HashedPersistentBlockState store pv)]), -- | Genesis data _genesisData :: !GenesisConfiguration, -- | Block pointer to genesis block - _genesisBlockPointer :: !(PersistentBlockPointer pv (PBS.HashedPersistentBlockState pv)), + _genesisBlockPointer :: !(PersistentBlockPointer pv (PBS.HashedPersistentBlockState store pv)), -- | Current focus block - _focusBlock :: !(PersistentBlockPointer pv (PBS.HashedPersistentBlockState pv)), + _focusBlock :: !(PersistentBlockPointer pv (PBS.HashedPersistentBlockState store pv)), -- | Pending transaction table _pendingTransactions :: !PendingTransactionTable, -- | Transaction table @@ -236,20 +236,20 @@ data SkovPersistentData (pv :: ProtocolVersion) = SkovPersistentData -- | Tree state directory _treeStateDirectory :: !FilePath, -- | Database handlers - _db :: !(DatabaseHandlers pv (TS.BlockStatePointer (PBS.HashedPersistentBlockState pv))), + _db :: !(DatabaseHandlers pv (TS.BlockStatePointer (PBS.HashedPersistentBlockState store pv))), -- | State where we store the initial state for the new protocol update. -- TODO: This is not an ideal solution, but seems simplest in terms of abstractions. -- 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 store pv)) } makeLenses ''SkovPersistentData instance - (bsp ~ TS.BlockStatePointer (PBS.HashedPersistentBlockState pv)) => - HasDatabaseHandlers pv bsp (SkovPersistentData pv) + (bsp ~ TS.BlockStatePointer (PBS.HashedPersistentBlockState store pv)) => + HasDatabaseHandlers pv bsp (SkovPersistentData store pv) where dbHandlers = db @@ -259,12 +259,12 @@ initialSkovPersistentDataDefault :: -- | Tree state directory FilePath -> GenesisConfiguration -> - PBS.HashedPersistentBlockState pv -> + PBS.HashedPersistentBlockState store pv -> -- | How to serialize the block state reference for inclusion in the table. - TS.BlockStatePointer (PBS.HashedPersistentBlockState pv) -> + TS.BlockStatePointer (PBS.HashedPersistentBlockState store pv) -> TransactionTable -> Maybe PendingTransactionTable -> - m (SkovPersistentData pv) + m (SkovPersistentData store pv) initialSkovPersistentDataDefault = initialSkovPersistentData defaultRuntimeParameters -- | Create an initial 'SkovPersistentData'. @@ -279,9 +279,9 @@ initialSkovPersistentData :: -- | Genesis data GenesisConfiguration -> -- | Genesis state - PBS.HashedPersistentBlockState pv -> + PBS.HashedPersistentBlockState store pv -> -- | Genesis block state - TS.BlockStatePointer (PBS.HashedPersistentBlockState pv) -> + TS.BlockStatePointer (PBS.HashedPersistentBlockState store pv) -> -- | The table of transactions to start the configuration with. If this -- transaction table has any non-finalized transactions then the pending -- table corresponding to those non-finalized transactions must be supplied. @@ -292,7 +292,7 @@ initialSkovPersistentData :: -- supplied to record these, satisfying the usual properties. See -- documentation of the 'PendingTransactionTable' for details. Maybe PendingTransactionTable -> - m (SkovPersistentData pv) + m (SkovPersistentData store pv) initialSkovPersistentData rp treeStateDir gd genState serState genTT mPending = do gb <- makeGenesisPersistentBlockPointer gd genState let gbh = bpHash gb @@ -398,13 +398,13 @@ checkExistingDatabase treeStateDir blockStateFile = do -- consuming, and it is not needed when starting a node on a chain which had -- multiple protocol updates. loadSkovPersistentData :: - forall pv. + forall store pv. (IsProtocolVersion pv) => RuntimeParameters -> -- | Tree state directory FilePath -> - PBS.PersistentBlockStateContext pv -> - LogIO (SkovPersistentData pv) + PBS.PersistentBlockStateContext store pv -> + LogIO (SkovPersistentData store pv) loadSkovPersistentData rp _treeStateDirectory pbsc = do -- we open the environment first. -- It might be that the database is bigger than the default environment size. @@ -469,12 +469,12 @@ loadSkovPersistentData rp _treeStateDirectory pbsc = do } where makeBlockPointer :: - StoredBlockWithStateHash pv (TS.BlockStatePointer (PBS.PersistentBlockState pv)) -> - LogIO (PersistentBlockPointer pv (PBS.HashedPersistentBlockState pv)) + StoredBlockWithStateHash pv (TS.BlockStatePointer (PBS.PersistentBlockState store pv)) -> + LogIO (PersistentBlockPointer pv (PBS.HashedPersistentBlockState store pv)) makeBlockPointer StoredBlockWithStateHash{sbshStoredBlock = StoredBlock{..}, ..} = do bstate <- runReaderT (PBS.runPersistentBlockStateMonad (loadBlockState sbshStateHash sbState)) pbsc makeBlockPointerFromPersistentBlock sbBlock bstate sbInfo - isBlockStateCorrupted :: StoredBlock pv (TS.BlockStatePointer (PBS.PersistentBlockState pv)) -> LogIO Bool + isBlockStateCorrupted :: StoredBlock pv (TS.BlockStatePointer (PBS.PersistentBlockState store pv)) -> LogIO Bool isBlockStateCorrupted block = not <$> runReaderT (PBS.runPersistentBlockStateMonad (isValidBlobRef (sbState block))) pbsc @@ -487,11 +487,11 @@ loadSkovPersistentData rp _treeStateDirectory pbsc = do -- This function will raise an IO exception in the following scenarios -- * in the block state, an account which is listed cannot be loaded activateSkovPersistentData :: - forall pv. + forall store pv. (IsProtocolVersion pv) => - PBS.PersistentBlockStateContext pv -> - SkovPersistentData pv -> - LogIO (SkovPersistentData pv) + PBS.PersistentBlockStateContext store pv -> + SkovPersistentData store pv -> + LogIO (SkovPersistentData store pv) activateSkovPersistentData pbsc uninitState = runBlockState $ do logEvent GlobalState LLTrace "Caching last finalized block and initializing transaction table" @@ -504,11 +504,11 @@ activateSkovPersistentData pbsc uninitState = logEvent GlobalState LLDebug "Finished initializing LMDB account map and module map" return $! uninitState{_transactionTable = tt} where - runBlockState a = runReaderT (PBS.runPersistentBlockStateMonad @pv a) pbsc + runBlockState a = runReaderT (PBS.runPersistentBlockStateMonad a) pbsc -- | Close the database associated with a 'SkovPersistentData'. -- The database should not be used after this. -closeSkovPersistentData :: SkovPersistentData pv -> IO () +closeSkovPersistentData :: SkovPersistentData store pv -> IO () closeSkovPersistentData = closeDatabase . _db -- | Newtype wrapper that provides an implementation of the TreeStateMonad using a persistent tree state. @@ -542,6 +542,8 @@ newtype PersistentTreeStateMonad state (m :: Type -> Type) (a :: Type) = Persist TimeMonad ) +type instance MBSStore (PersistentTreeStateMonad state m) = MBSStore m + deriving instance (TokenStateOperations ts m) => TokenStateOperations ts (PersistentTreeStateMonad state m) deriving instance (PLTQuery bs ts m) => PLTQuery bs ts (PersistentTreeStateMonad state m) @@ -559,10 +561,10 @@ deriving instance instance GlobalStateTypes (PersistentTreeStateMonad state m) where type BlockPointerType (PersistentTreeStateMonad state m) = PersistentBlockPointer (MPV m) (BlockState m) -class (HasDatabaseHandlers pv (BlockStatePointer (PBS.PersistentBlockState pv)) s) => HasSkovPersistentData pv s | s -> pv where - skovPersistentData :: Lens' s (SkovPersistentData pv) +class (HasDatabaseHandlers pv (BlockStatePointer (PBS.PersistentBlockState store pv)) s) => HasSkovPersistentData store pv s | s -> store pv where + skovPersistentData :: Lens' s (SkovPersistentData store pv) -instance HasSkovPersistentData pv (SkovPersistentData pv) where +instance HasSkovPersistentData store pv (SkovPersistentData store pv) where skovPersistentData = id getWeakPointer :: @@ -570,15 +572,15 @@ getWeakPointer :: MonadIO (PersistentTreeStateMonad state m), BlockStateStorage (PersistentTreeStateMonad state m), MPV m ~ pv, - HasSkovPersistentData pv state, - BlockState (PersistentTreeStateMonad state m) ~ PBS.HashedPersistentBlockState pv, + HasSkovPersistentData store pv state, + BlockState (PersistentTreeStateMonad state m) ~ PBS.HashedPersistentBlockState store pv, MonadState state (PersistentTreeStateMonad state m), MonadProtocolVersion m ) => - Weak (PersistentBlockPointer (MPV m) (PBS.HashedPersistentBlockState pv)) -> + Weak (PersistentBlockPointer (MPV m) (PBS.HashedPersistentBlockState store pv)) -> BlockHash -> String -> - PersistentTreeStateMonad state m (PersistentBlockPointer (MPV m) (PBS.HashedPersistentBlockState pv)) + PersistentTreeStateMonad state m (PersistentBlockPointer (MPV m) (PBS.HashedPersistentBlockState store pv)) getWeakPointer weakPtr ptrHash name = do d <- liftIO $ deRefWeak weakPtr case d of @@ -608,9 +610,9 @@ instance MonadLogger (PersistentTreeStateMonad state m), MonadIO (PersistentTreeStateMonad state m), MPV m ~ pv, - BlockState m ~ PBS.HashedPersistentBlockState pv, + BlockState m ~ PBS.HashedPersistentBlockState store pv, BlockStateStorage (PersistentTreeStateMonad state m), - HasSkovPersistentData pv state, + HasSkovPersistentData store pv state, MonadState state (PersistentTreeStateMonad state m), MonadProtocolVersion m ) => @@ -636,8 +638,8 @@ constructBlock StoredBlockWithStateHash{sbshStoredBlock = StoredBlock{..}, ..} = instance ( MonadState state m, - HasSkovPersistentData pv state, - BlockState m ~ PBS.HashedPersistentBlockState pv, + HasSkovPersistentData store pv state, + BlockState m ~ PBS.HashedPersistentBlockState store pv, MonadProtocolVersion m, MPV m ~ pv, MonadLogger (PersistentTreeStateMonad state m), @@ -664,10 +666,10 @@ instance BlockStateStorage (PersistentTreeStateMonad state m), MonadState state m, BlockStateQuery m, - HasSkovPersistentData pv state, + HasSkovPersistentData store pv state, MonadProtocolVersion m, MPV m ~ pv, - BlockState m ~ PBS.HashedPersistentBlockState pv + BlockState m ~ PBS.HashedPersistentBlockState store pv ) => TS.TreeStateMonad (PersistentTreeStateMonad state m) where diff --git a/concordium-consensus/src/Concordium/ImportExport.hs b/concordium-consensus/src/Concordium/ImportExport.hs index 26b7f30988..192b88f852 100644 --- a/concordium-consensus/src/Concordium/ImportExport.hs +++ b/concordium-consensus/src/Concordium/ImportExport.hs @@ -520,14 +520,14 @@ exportConsensusV0Blocks firstBlock outDir chunkSize genIndex startHeight blockIn -- | Export blocks from a 'ConsensusV1' database. exportConsensusV1Blocks :: - forall pv m r. + forall pv m r store. ( IsProtocolVersion pv, MonadIO m, KonsensusV1.MonadTreeStateStore m, MonadLogger m, MPV m ~ pv, MonadReader r m, - KonsensusV1.HasDatabaseHandlers r pv, + KonsensusV1.HasDatabaseHandlers r store pv, MonadCatch m ) => -- | Export path. @@ -664,7 +664,7 @@ exportSections dbDir outDir chunkSize genIndex startHeight blockIndex lastWritte Nothing -> do logEvent External LLError $ "Tree state database could not be opened: " <> show treeStateDir return (True, Empty) - Just (KonsensusV1.VersionDatabaseHandlers (dbh :: KonsensusV1.DatabaseHandlers pv)) -> + Just (KonsensusV1.VersionDatabaseHandlers (dbh :: KonsensusV1.DatabaseHandlers store pv)) -> runReaderT ( KonsensusV1.runDiskLLDBM $ do exportResult <- exportConsensusV1Blocks @pv outDir chunkSize genIndex startHeight blockIndex lastWrittenChunkM diff --git a/concordium-consensus/src/Concordium/KonsensusV1.hs b/concordium-consensus/src/Concordium/KonsensusV1.hs index 79e18c27ee..9e06a8389d 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1.hs @@ -12,6 +12,7 @@ import Lens.Micro.Platform import qualified Concordium.Genesis.Data.BaseV1 as BaseV1 import Concordium.GlobalState.BlockState +import Concordium.GlobalState.Persistent.BlobStore (MBSStore) import Concordium.GlobalState.Persistent.BlockState import qualified Concordium.GlobalState.Persistent.BlockState as PBS import qualified Concordium.GlobalState.TransactionTable as TT @@ -45,12 +46,12 @@ receiveFinalizationMessage :: BlockStateStorage m, TimeMonad m, MonadTimeout m, - MonadState (SkovData (MPV m)) m, + MonadState (SkovData (MBSStore m) (MPV m)) m, MonadReader r m, HasBakerContext r, MonadConsensusEvent m, MonadLogger m, - BlockState m ~ HashedPersistentBlockState (MPV m), + BlockState m ~ HashedPersistentBlockState (MBSStore m) (MPV m), MonadTreeStateStore m, MonadBroadcast m, TimerMonad m @@ -89,16 +90,16 @@ addTransactionResult (Transactions.NotAdded verRes) = transactionVerificationResultToUpdateResult verRes -- | Force a purge of the transaction table. -purgeTransactions :: (TimeMonad m, MonadState (SkovData pv) m) => m () +purgeTransactions :: (TimeMonad m, MonadState (SkovData (MBSStore m) pv) m) => m () purgeTransactions = purgeTransactionTable True =<< currentTime -- | Start the timeout timer and trigger baking (if possible). startEvents :: ( MonadReader r m, HasBakerContext r, - MonadState (SkovData (MPV m)) m, + MonadState (SkovData (MBSStore m) (MPV m)) m, BlockStateStorage m, - BlockState m ~ HashedPersistentBlockState (MPV m), + BlockState m ~ HashedPersistentBlockState (MBSStore m) (MPV m), IsConsensusV1 (MPV m), LowLevel.MonadTreeStateStore m, TimeMonad m, @@ -122,7 +123,9 @@ startEvents = do -- | Get the block state of the terminal block. -- This MUST only be called once the consensus is in shutdown. -getTerminalBlockState :: (MonadState (SkovData (MPV m)) m) => m (PBS.HashedPersistentBlockState (MPV m)) +getTerminalBlockState :: + (MonadState (SkovData (MBSStore m) (MPV m)) m) => + m (PBS.HashedPersistentBlockState (MBSStore m) (MPV m)) getTerminalBlockState = use terminalBlock <&> \case Absent -> error "Consensus was expected to be shut down, but terminal block is not present." @@ -133,7 +136,7 @@ getTerminalBlockState = -- This returns the transaction table and the pending transaction table (which is with respect to -- the last finalized block). clearSkov :: - (MonadState (SkovData (MPV m)) m) => + (MonadState (SkovData (MBSStore m) (MPV m)) m) => m (TT.TransactionTable, TT.PendingTransactionTable) clearSkov = do lfb <- use lastFinalized @@ -150,8 +153,8 @@ clearSkov = do -- This clears the transaction table and pending transactions, ensures that the block states are -- archived, and collapses the block state caches. terminateSkov :: - ( MonadState (SkovData (MPV m)) m, - BlockState m ~ HashedPersistentBlockState (MPV m), + ( MonadState (SkovData (MBSStore m) (MPV m)) m, + BlockState m ~ HashedPersistentBlockState (MBSStore m) (MPV m), BlockStateStorage m ) => m () diff --git a/concordium-consensus/src/Concordium/KonsensusV1/Consensus.hs b/concordium-consensus/src/Concordium/KonsensusV1/Consensus.hs index 8a92597e63..ecc98b27c6 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/Consensus.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/Consensus.hs @@ -26,6 +26,7 @@ import qualified Concordium.Crypto.BlockSignature as Sig import Concordium.Genesis.Data.BaseV1 import Concordium.GlobalState.BakerInfo import qualified Concordium.GlobalState.BlockState as BS +import Concordium.GlobalState.Persistent.BlobStore (MBSStore) import qualified Concordium.GlobalState.Persistent.BlockState as PBS import qualified Concordium.GlobalState.TreeState as GSTypes import Concordium.KonsensusV1.LeaderElection @@ -55,7 +56,7 @@ class MonadBroadcast m where -- handle these events. class MonadConsensusEvent m where -- | Called when a block becomes live. - onBlock :: BlockPointer (MPV m) -> m () + onBlock :: BlockPointer (MBSStore m) (MPV m) -> m () -- | Called when a block becomes finalized. This is called once per finalization with a list -- of all the blocks that are newly finalized. @@ -63,7 +64,7 @@ class MonadConsensusEvent m where -- | Finalization entry that establishes finalization. FinalizationEntry (MPV m) -> -- | List of the newly-finalized blocks by increasing height. - [BlockPointer (MPV m)] -> + [BlockPointer (MBSStore m) (MPV m)] -> m () -- | A baker context containing the baker identity. Used for accessing relevant baker keys and the baker id. @@ -79,7 +80,7 @@ class MonadTimeout m where resetTimer :: Duration -> m () -- | Call 'resetTimer' with the current timeout. -resetTimerWithCurrentTimeout :: (MonadTimeout m, MonadState (SkovData (MPV m)) m) => m () +resetTimerWithCurrentTimeout :: (MonadTimeout m, MonadState (SkovData store (MPV m)) m) => m () resetTimerWithCurrentTimeout = resetTimer =<< use (roundStatus . rsCurrentTimeout) -- | Reset the timeout timer, and clear the collected quorum and timeout messages for the current @@ -87,7 +88,7 @@ resetTimerWithCurrentTimeout = resetTimer =<< use (roundStatus . rsCurrentTimeou -- 'advanceRoundWithQuorum'. onNewRound :: ( MonadTimeout m, - MonadState (SkovData (MPV m)) m + MonadState (SkovData store (MPV m)) m ) => m () onNewRound = do @@ -114,10 +115,10 @@ onNewRound = do advanceRoundWithTimeout :: ( MonadTimeout m, LowLevel.MonadTreeStateStore m, - MonadState (SkovData (MPV m)) m, + MonadState (SkovData store (MPV m)) m, MonadLogger m ) => - RoundTimeout (MPV m) -> + RoundTimeout store (MPV m) -> m () advanceRoundWithTimeout roundTimeout@RoundTimeout{..} = do logEvent Konsensus LLDebug $ @@ -141,11 +142,11 @@ advanceRoundWithTimeout roundTimeout@RoundTimeout{..} = do -- * The certified block MUST be for a round that is at least the current round. advanceRoundWithQuorum :: ( MonadTimeout m, - MonadState (SkovData (MPV m)) m, + MonadState (SkovData store (MPV m)) m, MonadLogger m ) => -- | Certified block - CertifiedBlock (MPV m) -> + CertifiedBlock store (MPV m) -> m () advanceRoundWithQuorum certBlock = do logEvent Konsensus LLDebug $ @@ -167,9 +168,9 @@ advanceRoundWithQuorum certBlock = do -- | Update the highest certified block if the supplied block is for a later round than the previous -- highest certified block. checkedUpdateHighestCertifiedBlock :: - (MonadState (SkovData (MPV m)) m) => + (MonadState (SkovData store (MPV m)) m) => -- | Certified block - CertifiedBlock (MPV m) -> + CertifiedBlock store (MPV m) -> m () checkedUpdateHighestCertifiedBlock newCB = do rs <- use roundStatus @@ -243,7 +244,7 @@ computeBakersAndFinalizers bakers fcp = withFinalizerForEpoch :: ( MonadReader r m, HasBakerContext r, - MonadState (SkovData (MPV m)) m, + MonadState (SkovData store (MPV m)) m, MonadLogger m ) => Epoch -> @@ -268,7 +269,7 @@ withFinalizerForEpoch epoch cont = do isCurrentFinalizer :: ( MonadReader r m, HasBakerContext r, - MonadState (SkovData (MPV m)) m + MonadState (SkovData store (MPV m)) m ) => m Bool isCurrentFinalizer = @@ -279,11 +280,11 @@ isCurrentFinalizer = return $ isJust $ finalizerByBakerId _bfFinalizers bakerId -- | Determine if consensus is shut down. -isShutDown :: (MonadState (SkovData (MPV m)) m) => m Bool +isShutDown :: (MonadState (SkovData store (MPV m)) m) => m Bool isShutDown = use isConsensusShutdown -- | The current state of the consensus with respect to the next protocol update. -data ProtocolUpdateState pv +data ProtocolUpdateState store pv = -- | No protocol update is currently anticipated. ProtocolUpdateStateNone | -- | A protocol update is currently scheduled. @@ -299,17 +300,17 @@ data ProtocolUpdateState pv | -- | A protocol update has taken place and the consensus is shut down. ProtocolUpdateStateDone { puProtocolUpdate :: !ProtocolUpdate, - puTerminalBlock :: !(BlockPointer pv) + puTerminalBlock :: !(BlockPointer store pv) } -- | Get the current protocol update state. getProtocolUpdateState :: - ( GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MPV m), + ( GSTypes.BlockState m ~ PBS.HashedPersistentBlockState store (MPV m), BS.BlockStateQuery m, - MonadState (SkovData (MPV m)) m, + MonadState (SkovData store (MPV m)) m, IsConsensusV1 (MPV m) ) => - m (ProtocolUpdateState (MPV m)) + m (ProtocolUpdateState store (MPV m)) getProtocolUpdateState = do st <- bpState <$> use lastFinalized BS.getProtocolUpdateStatus st >>= \case @@ -342,12 +343,12 @@ getProtocolUpdateState = do -- If the baker is not a baker in the current reward period, this will give a time at the start -- of the next reward period. bakerEarliestWinTimestamp :: - ( GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MPV m), + ( GSTypes.BlockState m ~ PBS.HashedPersistentBlockState store (MPV m), BS.BlockStateQuery m, IsConsensusV1 (MPV m) ) => BakerId -> - SkovData (MPV m) -> + SkovData store (MPV m) -> m Timestamp bakerEarliestWinTimestamp baker sd = do let lfBlock = sd ^. lastFinalized @@ -402,13 +403,13 @@ bakerEarliestWinTimestamp baker sd = do -- block in a higher round). getWinningBakersForEpoch :: forall m. - ( GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MPV m), + ( GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MBSStore m) (MPV m), BS.BlockStateQuery m, LowLevel.MonadTreeStateStore m, MonadIO m ) => Epoch -> - SkovData (MPV m) -> + SkovData (MBSStore m) (MPV m) -> m (Maybe [WinningBaker]) getWinningBakersForEpoch targetEpoch sd = do -- We start with the first finalized block of the next epoch. @@ -433,7 +434,7 @@ getWinningBakersForEpoch targetEpoch sd = do -- backwards to the round after the first ancestor of @startBlock@ that is in an earlier -- epoch than @targetEpoch@. let go :: - BlockPointer (MPV m) -> -- Block in at most round @rnd@ + BlockPointer (MBSStore m) (MPV m) -> -- Block in at most round @rnd@ Round -> -- Next round to include in list [WinningBaker] -> -- Currently accumulated list m [WinningBaker] diff --git a/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Blocks.hs b/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Blocks.hs index edfc33780c..093208facb 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Blocks.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Blocks.hs @@ -37,6 +37,7 @@ import Concordium.Genesis.Data.BaseV1 import Concordium.GlobalState.BakerInfo import Concordium.GlobalState.BlockState import Concordium.GlobalState.Parameters hiding (getChainParameters) +import Concordium.GlobalState.Persistent.BlobStore (MBSStore) import Concordium.GlobalState.Persistent.BlockState import Concordium.GlobalState.PurgeTransactions import Concordium.GlobalState.Statistics @@ -116,9 +117,9 @@ data BlockResult pv uponReceivingBlock :: ( IsConsensusV1 (MPV m), LowLevel.MonadTreeStateStore m, - MonadState (SkovData (MPV m)) m, + MonadState (SkovData (MBSStore m) (MPV m)) m, BlockStateStorage m, - BlockState m ~ HashedPersistentBlockState (MPV m), + BlockState m ~ HashedPersistentBlockState (MBSStore m) (MPV m), MonadLogger m ) => PendingBlock (MPV m) -> @@ -185,12 +186,12 @@ uponReceivingBlock pendingBlock = do receiveBlockKnownParent :: ( IsConsensusV1 (MPV m), LowLevel.MonadTreeStateStore m, - MonadState (SkovData (MPV m)) m, + MonadState (SkovData (MBSStore m) (MPV m)) m, BlockStateStorage m, - BlockState m ~ HashedPersistentBlockState (MPV m), + BlockState m ~ HashedPersistentBlockState (MBSStore m) (MPV m), MonadLogger m ) => - BlockPointer (MPV m) -> + BlockPointer (MBSStore m) (MPV m) -> PendingBlock (MPV m) -> m (BlockResult (MPV m)) receiveBlockKnownParent parent pendingBlock = do @@ -330,7 +331,7 @@ receiveBlockKnownParent parent pendingBlock = do -- function returns 'BlockResultEarly'. Otherwise, it returns 'BlockResultPending'. receiveBlockUnknownParent :: ( LowLevel.MonadTreeStateStore m, - MonadState (SkovData (MPV m)) m, + MonadState (SkovData (MBSStore m) (MPV m)) m, MonadLogger m ) => PendingBlock (MPV m) -> @@ -353,9 +354,9 @@ receiveBlockUnknownParent pendingBlock = do getMinBlockTime :: ( IsConsensusV1 (MPV m), BlockStateQuery m, - BlockState m ~ HashedPersistentBlockState (MPV m) + BlockState m ~ HashedPersistentBlockState (MBSStore m) (MPV m) ) => - BlockPointer (MPV m) -> + BlockPointer (MBSStore m) (MPV m) -> m Duration getMinBlockTime b = do cp <- getChainParameters (bpState b) @@ -378,16 +379,16 @@ getMinBlockTime b = do -- * The block must not already be a live block. addBlock :: forall m. - (TimeMonad m, MonadState (SkovData (MPV m)) m, MonadConsensusEvent m, MonadLogger m, IsProtocolVersion (MPV m)) => + (TimeMonad m, MonadState (SkovData (MBSStore m) (MPV m)) m, MonadConsensusEvent m, MonadLogger m, IsProtocolVersion (MPV m)) => -- | Block to add PendingBlock (MPV m) -> -- | Block state - HashedPersistentBlockState (MPV m) -> + HashedPersistentBlockState (MBSStore m) (MPV m) -> -- | Parent pointer - BlockPointer (MPV m) -> + BlockPointer (MBSStore m) (MPV m) -> -- | Energy used in executing the block Energy -> - m (BlockPointer (MPV m)) + m (BlockPointer (MBSStore m) (MPV m)) addBlock pendingBlock blockState parent energyUsed = do let height = blockHeight parent + 1 now <- currentTime @@ -433,9 +434,9 @@ processBlock :: forall m. ( IsConsensusV1 (MPV m), BlockStateStorage m, - BlockState m ~ HashedPersistentBlockState (MPV m), + BlockState m ~ HashedPersistentBlockState (MBSStore m) (MPV m), LowLevel.MonadTreeStateStore m, - MonadState (SkovData (MPV m)) m, + MonadState (SkovData (MBSStore m) (MPV m)) m, MonadIO m, TimeMonad m, MonadThrow m, @@ -444,10 +445,10 @@ processBlock :: MonadLogger m ) => -- | Parent block (@parent@) - BlockPointer (MPV m) -> + BlockPointer (MBSStore m) (MPV m) -> -- | Block being processed (@pendingBlock@) VerifiedBlock (MPV m) -> - m (Maybe (BlockPointer (MPV m))) + m (Maybe (BlockPointer (MBSStore m) (MPV m))) processBlock parent VerifiedBlock{vbBlock = pendingBlock, ..} -- Check that the QC is consistent with the parent block round. | qcRound (blockQuorumCertificate pendingBlock) /= blockRound parent = do @@ -867,9 +868,9 @@ processBlock parent VerifiedBlock{vbBlock = pendingBlock, ..} -- a higher 'Epoch' then neither of those will be signed. -- In the lower 'Round' case then the 'Round' would've timed out (hence the higher 'Epoch') -- and in the lower 'Epoch' case the consensus runner will already be an 'Epoch' ahead. -newtype OrderedBlock pv = OrderedBlock {theOrderedBlock :: BlockPointer pv} +newtype OrderedBlock store pv = OrderedBlock {theOrderedBlock :: BlockPointer store pv} -instance Ord (OrderedBlock pv) where +instance Ord (OrderedBlock store pv) where compare = compare `on` toTuple where @@ -880,7 +881,7 @@ instance Ord (OrderedBlock pv) where getHash @BlockHash blk ) -instance Eq (OrderedBlock pv) where +instance Eq (OrderedBlock store pv) where a == b = compare a b == EQ -- | Produce a quorum signature on a block. @@ -891,14 +892,14 @@ instance Eq (OrderedBlock pv) where -- epoch of the block, and that the baker identity matches the finalizer info (i.e. the keys -- are correct). validateBlock :: - ( MonadState (SkovData (MPV m)) m, + ( MonadState (SkovData (MBSStore m) (MPV m)) m, MonadBroadcast m, LowLevel.MonadTreeStateStore m, IsConsensusV1 (MPV m), MonadThrow m, MonadIO m, BlockStateStorage m, - BlockState m ~ HashedPersistentBlockState (MPV m), + BlockState m ~ HashedPersistentBlockState (MBSStore m) (MPV m), MonadReader r m, HasBakerContext r, TimeMonad m, @@ -975,13 +976,13 @@ checkedValidateBlock :: BlockData b, HashableTo BlockHash b, TimerMonad m, - MonadState (SkovData (MPV m)) m, + MonadState (SkovData (MBSStore m) (MPV m)) m, MonadBroadcast m, LowLevel.MonadTreeStateStore m, MonadThrow m, MonadIO m, BlockStateStorage m, - BlockState m ~ HashedPersistentBlockState (MPV m), + BlockState m ~ HashedPersistentBlockState (MBSStore m) (MPV m), TimeMonad m, MonadTimeout m, MonadConsensusEvent m, @@ -1010,9 +1011,9 @@ checkedValidateBlock validBlock = do executeBlock :: ( IsConsensusV1 (MPV m), BlockStateStorage m, - BlockState m ~ HashedPersistentBlockState (MPV m), + BlockState m ~ HashedPersistentBlockState (MBSStore m) (MPV m), LowLevel.MonadTreeStateStore m, - MonadState (SkovData (MPV m)) m, + MonadState (SkovData (MBSStore m) (MPV m)) m, MonadIO m, TimeMonad m, MonadThrow m, @@ -1038,7 +1039,7 @@ executeBlock verifiedBlock = do -- * Block production -- | Inputs used for baking a new block. -data BakeBlockInputs (pv :: ProtocolVersion) = BakeBlockInputs +data BakeBlockInputs store (pv :: ProtocolVersion) = BakeBlockInputs { -- | Secret keys for the baker. bbiBakerIdentity :: BakerIdentity, -- | Round in which the block is to be produced. @@ -1047,7 +1048,7 @@ data BakeBlockInputs (pv :: ProtocolVersion) = BakeBlockInputs -- Should always be either @blockEpoch bbiParent@ or @1 + blockEpoch bbiParent@. bbiEpoch :: Epoch, -- | Parent block. - bbiParent :: BlockPointer pv, + bbiParent :: BlockPointer store pv, -- | A valid quorum certificate for the parent block. bbiQuorumCertificate :: QuorumCertificate, -- | If the parent block belongs to a round earlier than @bbiRound - 1@, this is a valid @@ -1084,13 +1085,13 @@ data BakeBlockInputs (pv :: ProtocolVersion) = BakeBlockInputs prepareBakeBlockInputs :: ( MonadReader r m, HasBakerContext r, - MonadState (SkovData (MPV m)) m, + MonadState (SkovData (MBSStore m) (MPV m)) m, BlockStateStorage m, - BlockState m ~ HashedPersistentBlockState (MPV m), + BlockState m ~ HashedPersistentBlockState (MBSStore m) (MPV m), IsConsensusV1 (MPV m), MonadLogger m ) => - m (Maybe (BakeBlockInputs (MPV m))) + m (Maybe (BakeBlockInputs (MBSStore m) (MPV m))) prepareBakeBlockInputs = runMaybeT $ do -- We directly set the @rsRoundEligibleToBake@ to 'False' here as -- even if the function returns early without producing the inputs required @@ -1187,16 +1188,16 @@ prepareBakeBlockInputs = runMaybeT $ do -- | Construct a block given 'BakeBlockInputs'. bakeBlock :: forall m. - ( MonadState (SkovData (MPV m)) m, + ( MonadState (SkovData (MBSStore m) (MPV m)) m, BlockStateStorage m, - BlockState m ~ HashedPersistentBlockState (MPV m), + BlockState m ~ HashedPersistentBlockState (MBSStore m) (MPV m), TimeMonad m, IsConsensusV1 (MPV m), LowLevel.MonadTreeStateStore m, MonadConsensusEvent m, MonadLogger m ) => - BakeBlockInputs (MPV m) -> + BakeBlockInputs (MBSStore m) (MPV m) -> m (SignedBlock (MPV m)) bakeBlock BakeBlockInputs{..} = do curTimestamp <- utcTimeToTimestamp <$> currentTime @@ -1288,13 +1289,13 @@ bakeBlock BakeBlockInputs{..} = do -- | Extract information from SkovData and the block state to compute the result block hash. computeBlockResultHash :: forall m. - ( MonadState (SkovData (MPV m)) m, + ( MonadState (SkovData (MBSStore m) (MPV m)) m, BlockStateStorage m, - BlockState m ~ HashedPersistentBlockState (MPV m), + BlockState m ~ HashedPersistentBlockState (MBSStore m) (MPV m), IsConsensusV1 (MPV m) ) => -- | The block state right after executing the block. - HashedPersistentBlockState (MPV m) -> + HashedPersistentBlockState (MBSStore m) (MPV m) -> -- | The relative block height for the block. BlockHeight -> -- | The epoch of the block. @@ -1358,9 +1359,9 @@ computeBlockResultHash newState relativeBlockHeight currentEpoch = do makeBlock :: ( MonadReader r m, HasBakerContext r, - MonadState (SkovData (MPV m)) m, + MonadState (SkovData (MBSStore m) (MPV m)) m, BlockStateStorage m, - BlockState m ~ HashedPersistentBlockState (MPV m), + BlockState m ~ HashedPersistentBlockState (MBSStore m) (MPV m), IsConsensusV1 (MPV m), LowLevel.MonadTreeStateStore m, TimeMonad m, diff --git a/concordium-consensus/src/Concordium/KonsensusV1/Consensus/CatchUp.hs b/concordium-consensus/src/Concordium/KonsensusV1/Consensus/CatchUp.hs index d3529c3c8c..5ce86da4c3 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/Consensus/CatchUp.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/Consensus/CatchUp.hs @@ -50,6 +50,7 @@ import Concordium.Types import Concordium.Types.HashableTo import Concordium.GlobalState.BlockState +import Concordium.GlobalState.Persistent.BlobStore (MBSStore) import qualified Concordium.GlobalState.Persistent.BlockState as PBS import qualified Concordium.GlobalState.Types as GSTypes import Concordium.KonsensusV1.Consensus @@ -99,7 +100,7 @@ makeTimeoutSet TimeoutMessages{..} = } -- | Generate a catch up status for the current state of the consensus. -makeCatchUpStatus :: SkovData pv -> CatchUpStatus +makeCatchUpStatus :: SkovData store pv -> CatchUpStatus makeCatchUpStatus sd = CatchUpStatus{..} where lfBlock = sd ^. lastFinalized @@ -114,7 +115,7 @@ makeCatchUpStatus sd = CatchUpStatus{..} Set.Set BlockHash -> -- Hashes of blocks with known children [BlockHash] -> -- Accumulated leaf blocks [BlockHash] -> -- Accumulated branch blocks - Seq.Seq [BlockPointer pv] -> -- Unprocessed non-finalized blocks by height + Seq.Seq [BlockPointer store pv] -> -- Unprocessed non-finalized blocks by height ( [BlockHash], -- Leaves [BlockHash] -- Branches ) @@ -156,7 +157,7 @@ makeCatchUpStatus sd = CatchUpStatus{..} isCatchUpRequired :: (LowLevel.MonadTreeStateStore m) => CatchUpStatus -> - SkovData (MPV m) -> + SkovData (MBSStore m) (MPV m) -> m Bool isCatchUpRequired CatchUpStatus{..} sd | cusCurrentRound > myCurrentRound || cusLastFinalizedRound > myLastFinalizedRound = @@ -226,7 +227,7 @@ handleCatchUpRequest :: LowLevel.MonadTreeStateStore m ) => CatchUpStatus -> - SkovData (MPV m) -> + SkovData (MBSStore m) (MPV m) -> m (CatchUpPartialResponse m) handleCatchUpRequest CatchUpStatus{..} skovData = do peerLFBStatus <- getBlockStatus cusLastFinalizedBlock skovData @@ -425,7 +426,7 @@ data TerminalDataResult processCatchUpTerminalData :: ( MonadReader r m, HasBakerContext r, - MonadState (SkovData (MPV m)) m, + MonadState (SkovData (MBSStore m) (MPV m)) m, TimeMonad m, TimerMonad m, MonadIO m, @@ -437,7 +438,7 @@ processCatchUpTerminalData :: MonadLogger m, MonadTimeout m, IsConsensusV1 (MPV m), - GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MPV m) + GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MBSStore m) (MPV m) ) => CatchUpTerminalData -> m TerminalDataResult @@ -684,8 +685,8 @@ processCatchUpTerminalData CatchUpTerminalData{..} = flip runContT return $ do "timeout message would trigger catch up" Timeout.ConsensusShutdown -> return currentProgress -makeCatchUpStatusMessage :: SkovData pv -> CatchUpMessage +makeCatchUpStatusMessage :: SkovData store pv -> CatchUpMessage makeCatchUpStatusMessage = CatchUpStatusMessage . (\s -> s{cusBranches = []}) . makeCatchUpStatus -makeCatchUpRequestMessage :: SkovData pv -> CatchUpMessage +makeCatchUpRequestMessage :: SkovData store pv -> CatchUpMessage makeCatchUpRequestMessage = CatchUpRequestMessage . makeCatchUpStatus diff --git a/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Finality.hs b/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Finality.hs index eb7a4a0d69..fbe3ae1006 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Finality.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Finality.hs @@ -25,6 +25,7 @@ import Concordium.Utils import Concordium.Genesis.Data.BaseV1 import Concordium.GlobalState.BlockState +import Concordium.GlobalState.Persistent.BlobStore (MBSStore) import qualified Concordium.GlobalState.Persistent.BlockState as PBS import Concordium.GlobalState.Statistics import qualified Concordium.GlobalState.Types as GSTypes @@ -48,12 +49,12 @@ import Concordium.Types.Option -- This function incorporates the functionality of @checkFinality@ from the bluepaper. processCertifiedBlock :: forall m. - ( MonadState (SkovData (MPV m)) m, + ( MonadState (SkovData (MBSStore m) (MPV m)) m, TimeMonad m, MonadIO m, LowLevel.MonadTreeStateStore m, BlockStateStorage m, - GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MPV m), + GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MBSStore m) (MPV m), MonadThrow m, MonadConsensusEvent m, MonadLogger m, @@ -61,7 +62,7 @@ processCertifiedBlock :: HasCallStack ) => -- | The newly-certified block. - CertifiedBlock (MPV m) -> + CertifiedBlock (MBSStore m) (MPV m) -> m () processCertifiedBlock cb@CertifiedBlock{..} | NormalBlock block <- bpBlock cbQuorumBlock, @@ -118,12 +119,12 @@ data CatchupFinalizationEntryResult -- finalization entry and that block is alive and non finalized. -- If the finalization entry can be verified then it is processed. catchupFinalizationEntry :: - ( MonadState (SkovData (MPV m)) m, + ( MonadState (SkovData (MBSStore m) (MPV m)) m, TimeMonad m, MonadIO m, LowLevel.MonadTreeStateStore m, BlockStateStorage m, - GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MPV m), + GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MBSStore m) (MPV m), MonadThrow m, MonadConsensusEvent m, MonadLogger m, @@ -172,19 +173,19 @@ catchupFinalizationEntry finEntry = do -- * The block is at most one epoch later than the last finalized block. (This is implied by -- the block being live.) processFinalizationEntry :: - ( MonadState (SkovData (MPV m)) m, + ( MonadState (SkovData (MBSStore m) (MPV m)) m, TimeMonad m, MonadIO m, LowLevel.MonadTreeStateStore m, BlockStateStorage m, - GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MPV m), + GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MBSStore m) (MPV m), MonadThrow m, MonadConsensusEvent m, MonadLogger m, IsConsensusV1 (MPV m) ) => -- | Pointer to the block that is finalized. - BlockPointer (MPV m) -> + BlockPointer (MBSStore m) (MPV m) -> -- | Finalization entry for the block. FinalizationEntry (MPV m) -> m () @@ -197,13 +198,13 @@ processFinalizationEntry newFinalizedPtr newFinalizationEntry = -- 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), + ( GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MBSStore m) (MPV m), BlockStateStorage m ) => -- | @True@ if the block is finalized, @False@ if it is certified. Bool -> - BlockPointer (MPV m) -> - m (LowLevel.StoredBlock (MPV m)) + BlockPointer (MBSStore m) (MPV m) -> + m (LowLevel.StoredBlock (MBSStore m) (MPV m)) makeStoredBlock finalized blockPtr = do statePointer <- saveBlockState (bpState blockPtr) when finalized $ saveGlobalMaps (bpState blockPtr) @@ -223,12 +224,12 @@ makeStoredBlock finalized blockPtr = do -- If this is provided, the certified block and its QC are written to the tree state database -- together with updating the finalized block and transaction indexes. processFinalizationHelper :: - ( MonadState (SkovData (MPV m)) m, + ( MonadState (SkovData (MBSStore m) (MPV m)) m, TimeMonad m, MonadIO m, LowLevel.MonadTreeStateStore m, BlockStateStorage m, - GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MPV m), + GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MBSStore m) (MPV m), MonadThrow m, MonadConsensusEvent m, MonadLogger m, @@ -236,11 +237,11 @@ processFinalizationHelper :: HasCallStack ) => -- | The newly finalized block. - BlockPointer (MPV m) -> + BlockPointer (MBSStore m) (MPV m) -> -- | Finalization entry for the block. FinalizationEntry (MPV m) -> -- | Optional newly-certified block to write to the low-level store. - Maybe (CertifiedBlock (MPV m)) -> + Maybe (CertifiedBlock (MBSStore m) (MPV m)) -> m () {-# INLINE processFinalizationHelper #-} processFinalizationHelper newFinalizedBlock newFinalizationEntry mCertifiedBlock = do @@ -361,15 +362,15 @@ processFinalizationHelper newFinalizedBlock newFinalizationEntry mCertifiedBlock -- if we have seen a QC on a block that justifies finalization of a trigger block, causing us to -- advance the epoch, but others did not see it and moved on.) checkedAdvanceEpoch :: - ( MonadState (SkovData (MPV m)) m, + ( MonadState (SkovData (MBSStore m) (MPV m)) m, IsConsensusV1 (MPV m), - GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MPV m), + GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MBSStore m) (MPV m), BlockStateQuery m ) => -- | Finalization entry. FinalizationEntry (MPV m) -> -- | The block that becomes finalized. - BlockPointer (MPV m) -> + BlockPointer (MBSStore m) (MPV m) -> m () checkedAdvanceEpoch finEntry newFinalizedBlock = do oldEpoch <- use (roundStatus . rsCurrentEpoch) @@ -400,15 +401,15 @@ getNextEpochBakersAndFinalizers finState = do -- previous one. checkedAdvanceEpochBakers :: ( IsConsensusV1 (MPV m), - GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MPV m), + GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MBSStore m) (MPV m), MonadState s m, BlockStateQuery m, HasEpochBakers s ) => -- | The previous last finalized block. - BlockPointer (MPV m) -> + BlockPointer (MBSStore m) (MPV m) -> -- | The new last finalized block. - BlockPointer (MPV m) -> + BlockPointer (MBSStore m) (MPV m) -> m () checkedAdvanceEpochBakers oldFinalizedBlock newFinalizedBlock | newEpoch == oldEpoch + 1 = do diff --git a/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Quorum.hs b/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Quorum.hs index 92251434b1..e659921856 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Quorum.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Quorum.hs @@ -20,6 +20,7 @@ import Concordium.Types.Parameters import Concordium.Utils import Concordium.GlobalState.BlockState +import Concordium.GlobalState.Persistent.BlobStore (MBSStore) import qualified Concordium.GlobalState.Persistent.BlockState as PBS import qualified Concordium.GlobalState.Types as GSTypes import Concordium.KonsensusV1.Consensus @@ -55,11 +56,11 @@ data ReceiveQuorumMessageRejectReason deriving (Eq, Show) -- | Result codes for receiving a 'QuorumMessage'. -data ReceiveQuorumMessageResult (pv :: ProtocolVersion) +data ReceiveQuorumMessageResult store (pv :: ProtocolVersion) = -- | The 'QuorumMessage' was received i.e. it passed verification. - Received !(VerifiedQuorumMessage pv) + Received !(VerifiedQuorumMessage store pv) | -- | The 'QuorumMessage' was received but is a result of double signing. - ReceivedNoRelay !(VerifiedQuorumMessage pv) + ReceivedNoRelay !(VerifiedQuorumMessage store pv) | -- | The 'QuorumMessage' was rejected. Rejected !ReceiveQuorumMessageRejectReason | -- | The 'QuorumMessage' points to a round which indicates a catch up is required. @@ -70,7 +71,7 @@ data ReceiveQuorumMessageResult (pv :: ProtocolVersion) -- | A _received_ and verified 'QuorumMessage' together with -- the weight associated with the finalizer for the quorum message. -data VerifiedQuorumMessage (pv :: ProtocolVersion) = VerifiedQuorumMessage +data VerifiedQuorumMessage store (pv :: ProtocolVersion) = VerifiedQuorumMessage { -- | The verified 'QuorumMessage'. vqmMessage :: !QuorumMessage, -- | The weight of the finalizer. @@ -78,7 +79,7 @@ data VerifiedQuorumMessage (pv :: ProtocolVersion) = VerifiedQuorumMessage -- | The baker id of the finalizer. vqmFinalizerBakerId :: !BakerId, -- | The block that is the target of the quorum message. - vqmBlock :: !(BlockPointer pv) + vqmBlock :: !(BlockPointer store pv) } deriving (Eq, Show) @@ -96,9 +97,9 @@ receiveQuorumMessage :: -- | The 'QuorumMessage' to receive. QuorumMessage -> -- | The tree state to verify the 'QuorumMessage' within. - SkovData (MPV m) -> + SkovData (MBSStore m) (MPV m) -> -- | Result of receiving the 'QuorumMessage'. - m (ReceiveQuorumMessageResult (MPV m)) + m (ReceiveQuorumMessageResult (MBSStore m) (MPV m)) receiveQuorumMessage qm@QuorumMessage{..} skovData = receive where receive @@ -191,7 +192,7 @@ receiveQuorumMessage qm@QuorumMessage{..} skovData = receive -- Precondition. The finalizer must not be present already. addQuorumMessage :: -- | The verified quorum message - VerifiedQuorumMessage pv -> + VerifiedQuorumMessage store pv -> -- | The messages to update. QuorumMessages -> -- | The resulting messages. @@ -225,10 +226,10 @@ addQuorumMessage makeQuorumCertificate :: -- | The block we want to check whether a -- can 'QuorumCertificate' can be formed or not. - BlockPointer pv -> + BlockPointer store pv -> -- | The state to use for making the -- 'QuorumCertificate'. - SkovData pv -> + SkovData store pv -> -- | Return @Just QuorumCertificate@ if there are enough (weighted) quorum signatures -- for the provided block. -- Otherwise return @Nothing@. @@ -275,14 +276,14 @@ processQuorumMessage :: BlockStateStorage m, TimeMonad m, MonadTimeout m, - MonadState (SkovData (MPV m)) m, + MonadState (SkovData (MBSStore m) (MPV m)) m, MonadConsensusEvent m, MonadLogger m, - GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MPV m), + GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MBSStore m) (MPV m), LowLevel.MonadTreeStateStore m ) => -- | The 'VerifiedQuorumMessage' to process. - VerifiedQuorumMessage (MPV m) -> + VerifiedQuorumMessage (MBSStore m) (MPV m) -> -- | Continuation to make a block m () -> m () diff --git a/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Timeout.hs b/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Timeout.hs index da31fed070..4d62e380e6 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Timeout.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Timeout.hs @@ -23,6 +23,7 @@ import Concordium.Types.Parameters hiding (getChainParameters) import Concordium.Utils import Concordium.GlobalState.BlockState +import Concordium.GlobalState.Persistent.BlobStore (MBSStore) import Concordium.GlobalState.Persistent.BlockState import qualified Concordium.GlobalState.Persistent.BlockState as PBS import Concordium.GlobalState.Types @@ -68,10 +69,10 @@ data ReceiveTimeoutMessageRejectReason -- | Possibly return codes for when receiving -- a 'TimeoutMessage'. -data ReceiveTimeoutMessageResult pv +data ReceiveTimeoutMessageResult store pv = -- | The 'TimeoutMessage' was well received and should -- be relayed onto the network. - Received !(PartiallyVerifiedTimeoutMessage pv) + Received !(PartiallyVerifiedTimeoutMessage store pv) | -- | The 'TimeoutMessage' could not be verified and should not be -- relayed. Rejected !ReceiveTimeoutMessageRejectReason @@ -85,7 +86,7 @@ data ReceiveTimeoutMessageResult pv -- | A partially verified 'TimeoutMessage' with its associated finalization committees. -- The timeout message is partially verified itself but the aggregate signature and -- associated quorum certificate are not. -data PartiallyVerifiedTimeoutMessage pv = PartiallyVerifiedTimeoutMessage +data PartiallyVerifiedTimeoutMessage store pv = PartiallyVerifiedTimeoutMessage { -- | The 'TimeoutMessage' that has been partially verified pvtmTimeoutMessage :: !TimeoutMessage, -- | The finalization committee with respect to the 'QuorumCertificate' contained @@ -96,7 +97,7 @@ data PartiallyVerifiedTimeoutMessage pv = PartiallyVerifiedTimeoutMessage pvtmAggregateSignatureValid :: Bool, -- | Block pointer for the block referenced by the 'QuorumCertificate' of the 'TimeoutMessage'. -- This is @Absent@ when the block that the 'QuorumCertificate' refers to is either 'BlockPending' or 'BlockUnknown'. - pvtmBlock :: !(Option (BlockPointer pv)) + pvtmBlock :: !(Option (BlockPointer store pv)) } deriving (Eq, Show) @@ -111,9 +112,9 @@ receiveTimeoutMessage :: -- | The 'TimeoutMessage' to receive. TimeoutMessage -> -- | The tree state to verify the 'TimeoutMessage' within. - SkovData (MPV m) -> + SkovData (MBSStore m) (MPV m) -> -- | Result of receiving the 'TimeoutMessage'. - m (ReceiveTimeoutMessageResult (MPV m)) + m (ReceiveTimeoutMessageResult (MBSStore m) (MPV m)) receiveTimeoutMessage tm@TimeoutMessage{tmBody = TimeoutMessageBody{..}} skovData -- Consensus has been shutdown. | skovData ^. isConsensusShutdown = return ConsensusShutdown @@ -265,10 +266,10 @@ executeTimeoutMessage :: BlockStateStorage m, TimeMonad m, MonadTimeout m, - MonadState (SkovData (MPV m)) m, + MonadState (SkovData (MBSStore m) (MPV m)) m, MonadConsensusEvent m, MonadLogger m, - GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MPV m), + GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MBSStore m) (MPV m), LowLevel.MonadTreeStateStore m, TimerMonad m, MonadBroadcast m, @@ -276,7 +277,7 @@ executeTimeoutMessage :: HasBakerContext r ) => -- | The partially verified 'TimeoutMessage' to execute. - PartiallyVerifiedTimeoutMessage (MPV m) -> + PartiallyVerifiedTimeoutMessage (MBSStore m) (MPV m) -> -- | Returns @Left TimeoutMessage@ if the 'QuorumCertificate' could not be verified, -- and otherwise @Right ()@. m ExecuteTimeoutMessageResult @@ -352,9 +353,9 @@ uponTimeoutEvent :: MonadBroadcast m, MonadReader r m, HasBakerContext r, - BlockState m ~ HashedPersistentBlockState (MPV m), + BlockState m ~ HashedPersistentBlockState (MBSStore m) (MPV m), IsConsensusV1 (MPV m), - MonadState (SkovData (MPV m)) m, + MonadState (SkovData (MBSStore m) (MPV m)) m, LowLevel.MonadTreeStateStore m, MonadLogger m, BlockStateStorage m, @@ -477,11 +478,11 @@ updateTimeoutMessages tms tm = processTimeout :: ( MonadTimeout m, LowLevel.MonadTreeStateStore m, - MonadState (SkovData (MPV m)) m, + MonadState (SkovData (MBSStore m) (MPV m)) m, MonadReader r m, HasBakerContext r, BlockStateStorage m, - BlockState m ~ HashedPersistentBlockState (MPV m), + BlockState m ~ HashedPersistentBlockState (MBSStore m) (MPV m), IsConsensusV1 (MPV m), TimeMonad m, TimerMonad m, diff --git a/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Timeout/Internal.hs b/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Timeout/Internal.hs index 9131ae1900..0f9d59f23f 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Timeout/Internal.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Timeout/Internal.hs @@ -16,6 +16,7 @@ import Concordium.Types.Parameters hiding (getChainParameters) import Concordium.Utils import Concordium.GlobalState.BlockState +import Concordium.GlobalState.Persistent.BlobStore (MBSStore) import Concordium.GlobalState.Persistent.BlockState import Concordium.GlobalState.Types import Concordium.KonsensusV1.TreeState.Implementation @@ -39,13 +40,13 @@ updateCurrentTimeout timeoutFactor oldCurrentTimeout = -- | Grow the current timeout duration in response to an elapsed timeout. -- This updates the timeout to @timeoutIncrease * oldTimeout@. growTimeout :: - ( BlockState m ~ HashedPersistentBlockState (MPV m), + ( BlockState m ~ HashedPersistentBlockState (MBSStore m) (MPV m), IsConsensusV1 (MPV m), BlockStateQuery m, - MonadState (SkovData (MPV m)) m + MonadState (SkovData (MBSStore m) (MPV m)) m ) => -- | Block to take the timeout parameters from - BlockPointer (MPV m) -> + BlockPointer (MBSStore m) (MPV m) -> m () growTimeout blockPtr = do chainParams <- getChainParameters $ bpState blockPtr @@ -58,13 +59,13 @@ growTimeout blockPtr = do -- This updates the current timeout to @max timeoutBase (timeoutDecrease * oldTimeout)@, where -- @timeoutBase@ and @timeoutDecrease@ are taken from the chain parameters of the supplied block. shrinkTimeout :: - ( BlockState m ~ HashedPersistentBlockState (MPV m), + ( BlockState m ~ HashedPersistentBlockState (MBSStore m) (MPV m), IsConsensusV1 (MPV m), BlockStateQuery m, - MonadState (SkovData (MPV m)) m + MonadState (SkovData (MBSStore m) (MPV m)) m ) => -- | Block to take the timeout parameters from - BlockPointer (MPV m) -> + BlockPointer (MBSStore m) (MPV m) -> m () shrinkTimeout blockPtr = do chainParams <- getChainParameters (bpState blockPtr) diff --git a/concordium-consensus/src/Concordium/KonsensusV1/Scheduler.hs b/concordium-consensus/src/Concordium/KonsensusV1/Scheduler.hs index e9ad4e5e44..1bd8fa809e 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/Scheduler.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/Scheduler.hs @@ -71,7 +71,7 @@ data ParticipatingBakers = ParticipatingBakers -- | Input data used for executing a block (besides the transactions). -- -- This is a short-lived datastructure used for parameter passing, hence its fields are lazy. -data BlockExecutionData (pv :: ProtocolVersion) = BlockExecutionData +data BlockExecutionData store (pv :: ProtocolVersion) = BlockExecutionData { -- | Indicates if the block is the first in a new epoch. bedIsNewEpoch :: Bool, -- | The duration of an epoch. (Obtained from genesis data.) @@ -83,7 +83,7 @@ data BlockExecutionData (pv :: ProtocolVersion) = BlockExecutionData -- | The block baker and QC signatories. bedParticipatingBakers :: ParticipatingBakers, -- | The block state of the parent block. - bedParentState :: PBS.HashedPersistentBlockState pv, + bedParentState :: PBS.HashedPersistentBlockState store pv, -- | Number of rounds a validator has missed (e.g. the validator was -- elected leader but a timeout certificate exist for the round) since the parent -- block. @@ -312,10 +312,10 @@ doUpdateSeedStateForBlock blkTimestamp blkNonce theState = do executeBlockPrologue :: ( pv ~ MPV m, BlockStateStorage m, - BlockState m ~ PBS.HashedPersistentBlockState pv, + BlockState m ~ PBS.HashedPersistentBlockState store pv, IsConsensusV1 pv ) => - BlockExecutionData pv -> + BlockExecutionData store pv -> m (PrologueResult m (AccountVersionFor (MPV m))) executeBlockPrologue BlockExecutionData{..} = do theState0 <- thawBlockState bedParentState @@ -506,11 +506,11 @@ processSuspensions snapshotSuspendedBids bs0 = do -- in a new payday. This also accrues the rewards for the block that will be paid at the next -- payday. executeBlockEpilogue :: - forall pv m. + forall store pv m. ( pv ~ MPV m, IsProtocolVersion pv, BlockStateStorage m, - BlockState m ~ PBS.HashedPersistentBlockState pv, + BlockState m ~ PBS.HashedPersistentBlockState store pv, IsConsensusV1 pv ) => ParticipatingBakers -> @@ -519,7 +519,7 @@ executeBlockEpilogue :: Map.Map BakerId Word64 -> Maybe (Set.Set BakerId) -> UpdatableBlockState m -> - m (PBS.HashedPersistentBlockState pv) + m (PBS.HashedPersistentBlockState store pv) executeBlockEpilogue participants paydayParams transactionRewardParams missedRounds snapshotSuspendedBids theState0 = do theState1 <- processPaydayRewards paydayParams theState0 theState2 <- processBlockRewards participants transactionRewardParams missedRounds theState1 @@ -668,13 +668,13 @@ executePostShutdownBlock parentState = do executeBlockState :: ( pv ~ MPV m, BlockStateStorage m, - BlockState m ~ PBS.HashedPersistentBlockState pv, + BlockState m ~ PBS.HashedPersistentBlockState store pv, IsConsensusV1 pv, MonadLogger m ) => - BlockExecutionData pv -> + BlockExecutionData store pv -> [(BlockItem, TVer.VerificationResult)] -> - m (Either (Maybe FailureKind) (PBS.HashedPersistentBlockState pv, Energy)) + m (Either (Maybe FailureKind) (PBS.HashedPersistentBlockState store pv, Energy)) executeBlockState execData@BlockExecutionData{..} transactions = do seedState <- getSeedState bedParentState if seedState ^. shutdownTriggered @@ -717,7 +717,7 @@ executeBlockState execData@BlockExecutionData{..} transactions = do constructBlockState :: ( pv ~ MPV m, BlockStateStorage m, - BlockState m ~ PBS.HashedPersistentBlockState pv, + BlockState m ~ PBS.HashedPersistentBlockState store pv, IsConsensusV1 pv, TimeMonad m, MonadLogger m @@ -725,8 +725,8 @@ constructBlockState :: RuntimeParameters -> TransactionTable -> PendingTransactionTable -> - BlockExecutionData pv -> - m (FilteredTransactions (TransactionOutcomesVersionFor pv), PBS.HashedPersistentBlockState pv, Energy) + BlockExecutionData store pv -> + m (FilteredTransactions (TransactionOutcomesVersionFor pv), PBS.HashedPersistentBlockState store pv, Energy) constructBlockState runtimeParams transactionTable pendingTable execData@BlockExecutionData{..} = do seedState <- getSeedState bedParentState if seedState ^. shutdownTriggered diff --git a/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs b/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs index 12c5785b1b..ad15e4d886 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs @@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingVia #-} +{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} @@ -63,19 +64,19 @@ import Concordium.TimerMonad -- * 'SkovV1T' -- | A 'HandlerEvent' is used to execute a handler after the current update has been processed. -data HandlerEvent pv +data HandlerEvent store pv = -- | Trigger the event handler for a block arriving. - OnBlock !(BlockPointer pv) + OnBlock !(BlockPointer store pv) | -- | Trigger the event handler for a finalization. - OnFinalize !(FinalizationEntry pv) ![BlockPointer pv] + OnFinalize !(FinalizationEntry pv) ![BlockPointer store pv] -- | The inner type of the 'SkovV1T' monad. -type InnerSkovV1T pv m = RWST (SkovV1Context pv m) (Seq.Seq (HandlerEvent pv)) (SkovV1State pv) m +type InnerSkovV1T store pv m = RWST (SkovV1Context store pv m) (Seq.Seq (HandlerEvent store pv)) (SkovV1State store pv) m -- | A type-alias that is used for deriving block state monad implementations for 'SkovV1T'. --- @PersistentBlockStateMonadHelper pv m a@ is representationally equivalent to @SkovV1T pv m a@. -type PersistentBlockStateMonadHelper pv m = - PersistentBlockStateMonad pv (SkovV1Context pv m) (InnerSkovV1T pv m) +-- @PersistentBlockStateMonadHelper store pv m a@ is representationally equivalent to @SkovV1T store pv m a@. +type PersistentBlockStateMonadHelper store pv m = + PersistentBlockStateMonad store pv (SkovV1Context store pv m) (InnerSkovV1T store pv m) -- | A monad transformer that provides functionality used by the consensus version 1 implementation. -- This provides the following instances (with suitable conditions on @pv@ and @m@): @@ -83,7 +84,7 @@ type PersistentBlockStateMonadHelper pv m = -- * Monadic behaviour lifted from the underlying monad @m@: 'Functor', 'Applicative', 'Monad', -- 'MonadIO', 'MonadLogger', 'TimeMonad', 'MonadThrow'. -- --- * @MonadReader (SkovV1Context pv m)@, where the 'SkovV1Context' implements 'HasBlobStore', +-- * @MonadReader (SkovV1Context store pv m)@, where the 'SkovV1Context' implements 'HasBlobStore', -- @'Cache.HasCache' ('AccountCache' (AccountVersionFor pv))@, -- @'Cache.HasCache' 'Modules.ModuleCache'@, 'HasHandlerContext', 'HasBakerContext', -- 'HasDatabaseHandlers' and 'LMDBAccountMap.HasDatabaseHandlers. @@ -110,8 +111,8 @@ type PersistentBlockStateMonadHelper pv m = -- unsupported protocol update. -- The handle makes sure we do not keep informing the user of the unsupported protocol -- by returning 'False' the first time it's called and 'True' for subsequent invocations. -newtype SkovV1T pv m a = SkovV1T - { runSkovT' :: InnerSkovV1T pv m a +newtype SkovV1T store (pv :: ProtocolVersion) m a = SkovV1T + { runSkovT' :: InnerSkovV1T store pv m a } deriving ( Functor, @@ -120,22 +121,24 @@ newtype SkovV1T pv m a = SkovV1T MonadIO, MonadLogger, TimeMonad, - MonadReader (SkovV1Context pv m), + MonadReader (SkovV1Context store pv m), MonadThrow, MonadCatch ) deriving (BlockStateTypes, ContractStateOperations, ModuleQuery) - via (PersistentBlockStateMonadHelper pv m) + via (PersistentBlockStateMonadHelper store pv m) + +type instance MBSStore (SkovV1T store pv m) = store -- | Run a 'SkovV1T' operation, given the context and state, returning the updated state and any -- handler events that were generated. runSkovT :: (Monad m) => - SkovV1T pv m a -> - SkovV1Context pv m -> - SkovV1State pv -> - m (a, SkovV1State pv, Seq.Seq (HandlerEvent pv)) + SkovV1T store pv m a -> + SkovV1Context store pv m -> + SkovV1State store pv -> + m (a, SkovV1State store pv, Seq.Seq (HandlerEvent store pv)) runSkovT comp ctx st = do (ret, st', evs) <- runRWST (runSkovT' comp) ctx st return (ret, st', evs) @@ -145,15 +148,15 @@ runSkovT comp ctx st = do -- used when the state is updated as changes to the 'SkovData' will be discarded, but changes to -- the disk-backed databases will persist. It is also expected that no handler events should be -- generated. -evalSkovT :: (Monad m) => SkovV1T pv m a -> SkovV1Context pv m -> SkovV1State pv -> m a +evalSkovT :: (Monad m) => SkovV1T store pv m a -> SkovV1Context store pv m -> SkovV1State store pv -> m a evalSkovT comp ctx st = do (ret, _) <- evalRWST (runSkovT' comp) ctx st return ret -- | The state used by the 'SkovV1T' monad. -data SkovV1State pv = SkovV1State +data SkovV1State store pv = SkovV1State { -- | The 'SkovData', which encapsulates the (in-memory) mutable state of the skov. - _v1sSkovData :: SkovData pv, + _v1sSkovData :: SkovData store pv, -- | The timer used for triggering timeout events. _v1sTimer :: Maybe ThreadTimer, -- | If we have already notified about an upcoming protocol update, this indicates the latest @@ -172,32 +175,32 @@ data HandlerContext (pv :: ProtocolVersion) m = HandlerContext } -- | Context used by the 'SkovV1T' monad. -data SkovV1Context (pv :: ProtocolVersion) m = SkovV1Context +data SkovV1Context store (pv :: ProtocolVersion) m = SkovV1Context { -- | The baker context (i.e. baker keys if any). _vcBakerContext :: !BakerContext, -- | Blob store and caches used by the block state storage. - _vcPersistentBlockStateContext :: !(PersistentBlockStateContext pv), + _vcPersistentBlockStateContext :: !(PersistentBlockStateContext store pv), -- | low-level tree state database. - _vcDisk :: !(DatabaseHandlers pv), + _vcDisk :: !(DatabaseHandlers store pv), -- | Handler functions. _vcHandlers :: !(HandlerContext pv m), -- | A function for unlifting @'SkovV1T' pv m@ into the 'IO' monad. -- This is used for implementing asynchronous behaviour, specifically timer events. - _skovV1TUnliftIO :: forall a. SkovV1T pv m a -> IO a + _skovV1TUnliftIO :: forall a. SkovV1T store pv m a -> IO a } -instance HasBlobStore (SkovV1Context pv m) where +instance HasBlobStore store (SkovV1Context store pv m) where blobStore = blobStore . _vcPersistentBlockStateContext blobLoadCallback = blobLoadCallback . _vcPersistentBlockStateContext blobStoreCallback = blobStoreCallback . _vcPersistentBlockStateContext -instance (AccountVersionFor pv ~ av) => Cache.HasCache (AccountCache av) (SkovV1Context pv m) where +instance (AccountVersionFor pv ~ av) => Cache.HasCache (AccountCache store av) (SkovV1Context store pv m) where projectCache = Cache.projectCache . _vcPersistentBlockStateContext -instance Cache.HasCache Modules.ModuleCache (SkovV1Context pv m) where +instance Cache.HasCache (Modules.ModuleCache store) (SkovV1Context store pv m) where projectCache = Cache.projectCache . _vcPersistentBlockStateContext -instance LMDBAccountMap.HasDatabaseHandlers (SkovV1Context pv m) where +instance LMDBAccountMap.HasDatabaseHandlers (SkovV1Context store pv m) where databaseHandlers = lens _vcPersistentBlockStateContext (\s v -> s{_vcPersistentBlockStateContext = v}) . LMDBAccountMap.databaseHandlers -- Note, these template haskell splices go here because of staging restrictions. @@ -207,16 +210,16 @@ makeLenses ''SkovV1Context makeLenses ''SkovV1State makeClassy ''HandlerContext -instance HasHandlerContext (SkovV1Context pv m) pv m where +instance HasHandlerContext (SkovV1Context store pv m) pv m where handlerContext = vcHandlers -instance HasBakerContext (SkovV1Context pv m) where +instance HasBakerContext (SkovV1Context store pv m) where bakerContext = vcBakerContext -instance HasDatabaseHandlers (SkovV1Context pv m) pv where +instance HasDatabaseHandlers (SkovV1Context store pv m) store pv where databaseHandlers = vcDisk -instance (MonadTrans (SkovV1T pv)) where +instance (MonadTrans (SkovV1T store pv)) where lift = SkovV1T . lift -- | A class used for implementing whether a protocol update has already been logged. @@ -232,80 +235,80 @@ class (Monad m) => AlreadyNotified m where -- is scheduled for the end of the present epoch. alreadyNotified :: ProtocolUpdate -> Bool -> m Bool -instance (IsProtocolVersion pv, Monad m) => AlreadyNotified (SkovV1T pv m) where +instance (IsProtocolVersion pv, Monad m) => AlreadyNotified (SkovV1T store pv m) where alreadyNotified pu b = SkovV1T $ do mOldPU <- notifiedProtocolUpdate <<.= Just (pu, b) return $ mOldPU == Just (pu, b) -instance (Monad m) => MonadState (SkovData pv) (SkovV1T pv m) where +instance (Monad m) => MonadState (SkovData store pv) (SkovV1T store pv m) where state = SkovV1T . state . v1sSkovData get = SkovV1T (use v1sSkovData) put = SkovV1T . (v1sSkovData .=) deriving via - (PersistentBlockStateMonadHelper pv m) + (PersistentBlockStateMonadHelper store pv m) instance - (IsProtocolVersion pv, MonadLogger m) => MonadProtocolVersion (SkovV1T pv m) + (IsProtocolVersion pv, MonadLogger m) => MonadProtocolVersion (SkovV1T store pv m) deriving via - (PersistentBlockStateMonadHelper pv m) + (PersistentBlockStateMonadHelper store pv m) instance - (IsProtocolVersion pv, MonadIO m, MonadLogger m) => AccountOperations (SkovV1T pv m) + (IsProtocolVersion pv, MonadIO m, MonadLogger m) => AccountOperations (SkovV1T store pv m) deriving via - (PersistentBlockStateMonadHelper pv m) + (PersistentBlockStateMonadHelper store pv m) instance (IsProtocolVersion pv, MonadIO m, MonadLogger m) => - TokenStateOperations StateV1.MutableState (SkovV1T pv m) + TokenStateOperations (StateV1.MutableState store) (SkovV1T store pv m) deriving via - (PersistentBlockStateMonadHelper pv m) + (PersistentBlockStateMonadHelper store pv m) instance (IsProtocolVersion pv, MonadIO m, MonadLogger m) => - PLTQuery (PersistentBlockState pv) StateV1.MutableState (SkovV1T pv m) + PLTQuery (PersistentBlockState store pv) (StateV1.MutableState store) (SkovV1T store pv m) deriving via - (PersistentBlockStateMonadHelper pv m) + (PersistentBlockStateMonadHelper store pv m) instance (IsProtocolVersion pv, MonadIO m, MonadLogger m) => - PLTQuery (HashedPersistentBlockState pv) StateV1.MutableState (SkovV1T pv m) + PLTQuery (HashedPersistentBlockState store pv) (StateV1.MutableState store) (SkovV1T store pv m) deriving via - (PersistentBlockStateMonadHelper pv m) + (PersistentBlockStateMonadHelper store pv m) instance - (IsProtocolVersion pv, MonadIO m, MonadLogger m) => BlockStateQuery (SkovV1T pv m) + (IsProtocolVersion pv, MonadIO m, MonadLogger m) => BlockStateQuery (SkovV1T store pv m) deriving via - (PersistentBlockStateMonadHelper pv m) + (PersistentBlockStateMonadHelper store pv m) instance - (IsProtocolVersion pv, MonadIO m, MonadLogger m) => BlockStateOperations (SkovV1T pv m) + (IsProtocolVersion pv, MonadIO m, MonadLogger m) => BlockStateOperations (SkovV1T store pv m) deriving via - (PersistentBlockStateMonadHelper pv m) + (PersistentBlockStateMonadHelper store pv m) instance - (IsProtocolVersion pv, MonadIO m, MonadLogger m) => BlockStateStorage (SkovV1T pv m) + (IsProtocolVersion pv, MonadIO m, MonadLogger m) => BlockStateStorage (SkovV1T store pv m) deriving via - (DiskLLDBM pv (InnerSkovV1T pv m)) + (DiskLLDBM store pv (InnerSkovV1T store pv m)) instance ( IsProtocolVersion pv, MonadIO m, MonadCatch m, MonadLogger m ) => - LowLevel.MonadTreeStateStore (SkovV1T pv m) + LowLevel.MonadTreeStateStore (SkovV1T store pv m) deriving via - (LMDBAccountMap.AccountMapStoreMonad (InnerSkovV1T pv m)) + (LMDBAccountMap.AccountMapStoreMonad (InnerSkovV1T store pv m)) instance ( IsProtocolVersion pv, MonadIO m, MonadCatch m, MonadLogger m ) => - LMDBAccountMap.MonadAccountMapStore (SkovV1T pv m) + LMDBAccountMap.MonadAccountMapStore (SkovV1T store pv m) -instance (Monad m) => MonadBroadcast (SkovV1T pv m) where +instance (Monad m) => MonadBroadcast (SkovV1T store pv m) where sendTimeoutMessage tm = do handler <- view sendTimeoutHandler lift $ handler tm @@ -316,12 +319,12 @@ instance (Monad m) => MonadBroadcast (SkovV1T pv m) where handler <- view sendBlockHandler lift $ handler sb -instance (Monad m) => MonadConsensusEvent (SkovV1T pv m) where +instance (Monad m) => MonadConsensusEvent (SkovV1T store pv m) where onBlock bp = SkovV1T $ tell $ Seq.singleton $ OnBlock bp onFinalize fe bp = SkovV1T $ tell $ Seq.singleton $ OnFinalize fe bp -instance (MonadIO m, MonadLogger m, MonadCatch m) => TimerMonad (SkovV1T pv m) where - type Timer (SkovV1T pv m) = ThreadTimer +instance (MonadIO m, MonadLogger m, MonadCatch m) => TimerMonad (SkovV1T store pv m) where + type Timer (SkovV1T store pv m) = ThreadTimer onTimeout timeout a = do ctx <- ask liftIO $ @@ -341,7 +344,7 @@ instance IsConsensusV1 pv, TimeMonad m ) => - MonadTimeout (SkovV1T pv m) + MonadTimeout (SkovV1T store pv m) where resetTimer dur = do mTimer <- SkovV1T $ use v1sTimer @@ -350,10 +353,10 @@ instance SkovV1T $ v1sTimer ?=! newTimer logEvent Runner LLTrace $ "Timeout reset for " ++ show (durationToNominalDiffTime dur) -instance GlobalStateTypes (SkovV1T pv m) where - type BlockPointerType (SkovV1T pv m) = BlockPointer pv +instance GlobalStateTypes (SkovV1T store pv m) where + type BlockPointerType (SkovV1T store pv m) = BlockPointer store pv -instance (IsProtocolVersion pv, MonadIO m, MonadCatch m, MonadLogger m) => BlockPointerMonad (SkovV1T pv m) where +instance (IsProtocolVersion pv, MonadIO m, MonadCatch m, MonadLogger m) => BlockPointerMonad (SkovV1T store pv m) where blockState = return . bpState bpParent = parentOf bpLastFinalized = lastFinalizedOf @@ -373,34 +376,34 @@ data GlobalStateConfig = GlobalStateConfig } -- | Context used by the 'InitMonad'. -data InitContext pv = InitContext +data InitContext store pv = InitContext { -- | Blob store and caches used by the block state storage. - _icPersistentBlockStateContext :: !(PersistentBlockStateContext pv), + _icPersistentBlockStateContext :: !(PersistentBlockStateContext store pv), -- | low-level tree state database. - _icDatabaseHandlers :: !(DatabaseHandlers pv) + _icDatabaseHandlers :: !(DatabaseHandlers store pv) } makeLenses ''InitContext -instance HasBlobStore (InitContext pv) where +instance HasBlobStore store (InitContext store pv) where blobStore = blobStore . _icPersistentBlockStateContext blobLoadCallback = blobLoadCallback . _icPersistentBlockStateContext blobStoreCallback = blobStoreCallback . _icPersistentBlockStateContext -instance (AccountVersionFor pv ~ av) => Cache.HasCache (AccountCache av) (InitContext pv) where +instance (AccountVersionFor pv ~ av) => Cache.HasCache (AccountCache store av) (InitContext store pv) where projectCache = Cache.projectCache . _icPersistentBlockStateContext -instance Cache.HasCache Modules.ModuleCache (InitContext pv) where +instance Cache.HasCache (Modules.ModuleCache store) (InitContext store pv) where projectCache = Cache.projectCache . _icPersistentBlockStateContext -instance HasDatabaseHandlers (InitContext pv) pv where +instance HasDatabaseHandlers (InitContext store pv) store pv where databaseHandlers = icDatabaseHandlers -instance LMDBAccountMap.HasDatabaseHandlers (InitContext pv) where +instance LMDBAccountMap.HasDatabaseHandlers (InitContext store pv) where databaseHandlers = icPersistentBlockStateContext . LMDBAccountMap.databaseHandlers -- | Inner type of 'InitMonad'. -type InnerInitMonad pv = ReaderT (InitContext pv) LogIO +type InnerInitMonad store pv = ReaderT (InitContext store pv) LogIO -- | A monad for initialising the consensus state. Unlike 'SkovV1T', it is not a monad transformer -- and it does not have a state component. This is necessary to avoid the bootstrapping problem @@ -409,7 +412,7 @@ type InnerInitMonad pv = ReaderT (InitContext pv) LogIO -- * Monadic behaviour: 'Functor', 'Applicative', 'Monad', 'MonadIO', 'MonadLogger', 'TimeMonad', -- 'MonadThrow', 'MonadCatch'. -- --- * @MonadReader (InitContext pv)@, where the 'InitContext' implements 'HasBlobStore', +-- * @MonadReader (InitContext store pv)@, where the 'InitContext' implements 'HasBlobStore', -- @'Cache.HasCache' ('AccountCache' (AccountVersionFor pv))@, -- @'Cache.HasCache' 'Modules.ModuleCache'@, and 'HasDatabaseHandlers'. -- @@ -420,7 +423,7 @@ type InnerInitMonad pv = ReaderT (InitContext pv) LogIO -- 'BlockStateStorage'. -- -- * LMDB-backed persistent tree state storage: 'LowLevel.MonadTreeStateStore'. -newtype InitMonad pv a = InitMonad {runInitMonad' :: InnerInitMonad pv a} +newtype InitMonad store pv a = InitMonad {runInitMonad' :: InnerInitMonad store pv a} deriving ( Functor, Applicative, @@ -428,7 +431,7 @@ newtype InitMonad pv a = InitMonad {runInitMonad' :: InnerInitMonad pv a} MonadIO, MonadLogger, TimeMonad, - MonadReader (InitContext pv), + MonadReader (InitContext store pv), MonadThrow, MonadCatch ) @@ -437,64 +440,66 @@ newtype InitMonad pv a = InitMonad {runInitMonad' :: InnerInitMonad pv a} ContractStateOperations, ModuleQuery, MonadBlobStore, - Cache.MonadCache Modules.ModuleCache, + Cache.MonadCache (Modules.ModuleCache store), LMDBAccountMap.MonadAccountMapStore, MonadModuleMapStore ) - via (PersistentBlockStateMonad pv (InitContext pv) (InnerInitMonad pv)) + via (PersistentBlockStateMonad store pv (InitContext store pv) (InnerInitMonad store pv)) + +type instance MBSStore (InitMonad store pv) = store deriving via - (PersistentBlockStateMonad pv (InitContext pv) (InnerInitMonad pv)) + (PersistentBlockStateMonad store pv (InitContext store pv) (InnerInitMonad store pv)) instance - (av ~ AccountVersionFor pv) => Cache.MonadCache (AccountCache av) (InitMonad pv) + (av ~ AccountVersionFor pv) => Cache.MonadCache (AccountCache store av) (InitMonad store pv) deriving via - (PersistentBlockStateMonad pv (InitContext pv) (InnerInitMonad pv)) + (PersistentBlockStateMonad store pv (InitContext store pv) (InnerInitMonad store pv)) instance - (IsProtocolVersion pv) => MonadProtocolVersion (InitMonad pv) + (IsProtocolVersion pv) => MonadProtocolVersion (InitMonad store pv) deriving via - (PersistentBlockStateMonad pv (InitContext pv) (InnerInitMonad pv)) + (PersistentBlockStateMonad store pv (InitContext store pv) (InnerInitMonad store pv)) instance - (IsProtocolVersion pv) => AccountOperations (InitMonad pv) + (IsProtocolVersion pv) => AccountOperations (InitMonad store pv) deriving via - (PersistentBlockStateMonad pv (InitContext pv) (InnerInitMonad pv)) + (PersistentBlockStateMonad store pv (InitContext store pv) (InnerInitMonad store pv)) instance - (IsProtocolVersion pv) => TokenStateOperations StateV1.MutableState (InitMonad pv) + (IsProtocolVersion pv) => TokenStateOperations (StateV1.MutableState store) (InitMonad store pv) deriving via - (PersistentBlockStateMonad pv (InitContext pv) (InnerInitMonad pv)) + (PersistentBlockStateMonad store pv (InitContext store pv) (InnerInitMonad store pv)) instance - (IsProtocolVersion pv) => PLTQuery (PersistentBlockState pv) StateV1.MutableState (InitMonad pv) + (IsProtocolVersion pv) => PLTQuery (PersistentBlockState store pv) (StateV1.MutableState store) (InitMonad store pv) deriving via - (PersistentBlockStateMonad pv (InitContext pv) (InnerInitMonad pv)) + (PersistentBlockStateMonad store pv (InitContext store pv) (InnerInitMonad store pv)) instance - (IsProtocolVersion pv) => PLTQuery (HashedPersistentBlockState pv) StateV1.MutableState (InitMonad pv) + (IsProtocolVersion pv) => PLTQuery (HashedPersistentBlockState store pv) (StateV1.MutableState store) (InitMonad store pv) deriving via - (PersistentBlockStateMonad pv (InitContext pv) (InnerInitMonad pv)) + (PersistentBlockStateMonad store pv (InitContext store pv) (InnerInitMonad store pv)) instance - (IsProtocolVersion pv) => BlockStateQuery (InitMonad pv) + (IsProtocolVersion pv) => BlockStateQuery (InitMonad store pv) deriving via - (PersistentBlockStateMonad pv (InitContext pv) (InnerInitMonad pv)) + (PersistentBlockStateMonad store pv (InitContext store pv) (InnerInitMonad store pv)) instance - (IsProtocolVersion pv) => BlockStateOperations (InitMonad pv) + (IsProtocolVersion pv) => BlockStateOperations (InitMonad store pv) deriving via - (PersistentBlockStateMonad pv (InitContext pv) (InnerInitMonad pv)) + (PersistentBlockStateMonad store pv (InitContext store pv) (InnerInitMonad store pv)) instance - (IsProtocolVersion pv) => BlockStateStorage (InitMonad pv) + (IsProtocolVersion pv) => BlockStateStorage (InitMonad store pv) deriving via - (DiskLLDBM pv (InitMonad pv)) + (DiskLLDBM store pv (InitMonad store pv)) instance (IsProtocolVersion pv) => - LowLevel.MonadTreeStateStore (InitMonad pv) + LowLevel.MonadTreeStateStore (InitMonad store pv) -- | Run an 'InitMonad' in a 'LogIO' context, given the 'InitContext'. -runInitMonad :: InitMonad pv a -> InitContext pv -> LogIO a +runInitMonad :: InitMonad store pv a -> InitContext store pv -> LogIO a runInitMonad = runReaderT . runInitMonad' -- | The result of successfully loading an existing SkovV1 state. -data ExistingSkov pv m = ExistingSkov +data ExistingSkov store pv m = ExistingSkov { -- | The context. - esContext :: !(SkovV1Context pv m), + esContext :: !(SkovV1Context store pv m), -- | The state. - esState :: !(SkovV1State pv), + esState :: !(SkovV1State store pv), -- | The hash of the current genesis block. esGenesisHash :: !BlockHash, -- | The effective protocol update if one has occurred, together with the relative @@ -504,19 +509,19 @@ data ExistingSkov pv m = ExistingSkov -- | Internal type used for deriving 'HasDatabaseHandlers' and 'LMDBAccountMap.HasDatabaseHandlers' -- used for computations where both lmdb databases are required. -data LMDBDatabases pv = LMDBDatabases +data LMDBDatabases store pv = LMDBDatabases { -- | the skov lmdb database - _lmdbSkov :: !(DatabaseHandlers pv), + _lmdbSkov :: !(DatabaseHandlers store pv), -- | the account map lmdb database _lmdbAccountMap :: !LMDBAccountMap.DatabaseHandlers } makeLenses ''LMDBDatabases -instance HasDatabaseHandlers (LMDBDatabases pv) pv where +instance HasDatabaseHandlers (LMDBDatabases store pv) store pv where databaseHandlers = lmdbSkov -instance LMDBAccountMap.HasDatabaseHandlers (LMDBDatabases pv) where +instance LMDBAccountMap.HasDatabaseHandlers (LMDBDatabases store pv) where databaseHandlers = lmdbAccountMap -- | Load an existing SkovV1 state. @@ -524,21 +529,22 @@ instance LMDBAccountMap.HasDatabaseHandlers (LMDBDatabases pv) where -- May throw a 'TreeStateInvariantViolation' if a database invariant violation occurs when -- attempting to load the state. initialiseExistingSkovV1 :: - forall pv m. + forall store pv m. (IsProtocolVersion pv, IsConsensusV1 pv) => GenesisBlockHeightInfo -> BakerContext -> HandlerContext pv m -> - (forall a. SkovV1T pv m a -> IO a) -> + (forall a. SkovV1T store pv m a -> IO a) -> GlobalStateConfig -> - LogIO (Maybe (ExistingSkov pv m)) + LogIO (Maybe (ExistingSkov store pv m)) initialiseExistingSkovV1 genesisBlockHeightInfo bakerCtx handlerCtx unliftSkov gsc@GlobalStateConfig{..} = do logEvent Skov LLDebug "Attempting to use existing global state." existingDB <- checkExistingDatabase gscTreeStateDirectory gscBlockStateFile if existingDB then do - pbsc <- newPersistentBlockStateContext False gsc - let initWithLLDB skovLldb = do + pbsc :: PersistentBlockStateContext store pv <- newPersistentBlockStateContext False gsc + let initWithLLDB :: DatabaseHandlers store pv -> LoggerT IO (Maybe (ExistingSkov store pv m)) + initWithLLDB skovLldb = do checkDatabaseVersion skovLldb let checkBlockState bs = runReaderT (PBS.runPersistentBlockStateMonad (isValidBlobRef bs)) pbsc RollbackResult{..} <- @@ -576,29 +582,36 @@ initialiseExistingSkovV1 genesisBlockHeightInfo bakerCtx handlerCtx unliftSkov g } return $ Just es let initWithBlockState = do - (lldb :: DatabaseHandlers pv) <- liftIO $ openDatabase gscTreeStateDirectory + (lldb :: DatabaseHandlers store pv) <- liftIO $ openDatabase gscTreeStateDirectory initWithLLDB lldb `onException` liftIO (closeDatabase lldb) initWithBlockState `onException` liftIO (closeBlobStore $ pbscBlobStore pbsc) else do logEvent Skov LLDebug "No existing global state." return Nothing +-- | A new SkovV1 instance, consisting of the 'SkovV1Context' and 'SkovV1State'. The @store@ +-- type is existentially quantified. +data NewSkov store pv m = NewSkov + { nsContext :: SkovV1Context store pv m, + nsState :: SkovV1State store pv + } + -- | Construct a new SkovV1 state based on the genesis data, initialising the disk storage. initialiseNewSkovV1 :: - forall pv m. + forall store pv m. (IsProtocolVersion pv, IsConsensusV1 pv) => GenesisData pv -> GenesisBlockHeightInfo -> BakerContext -> HandlerContext pv m -> - (forall a. SkovV1T pv m a -> IO a) -> + (forall a. SkovV1T store pv m a -> IO a) -> GlobalStateConfig -> - LogIO (SkovV1Context pv m, SkovV1State pv) + LogIO (NewSkov store pv m) initialiseNewSkovV1 genData genesisBlockHeightInfo bakerCtx handlerCtx unliftSkov gsConfig@GlobalStateConfig{..} = do logEvent Skov LLDebug "Creating new global state." pbsc@PersistentBlockStateContext{..} <- newPersistentBlockStateContext True gsConfig let - initGS :: InitMonad pv (SkovData pv) + initGS :: InitMonad store pv (SkovData store pv) initGS = do logEvent GlobalState LLTrace "Creating persistent global state" result <- genesisState genData @@ -633,24 +646,27 @@ initialiseNewSkovV1 genData genesisBlockHeightInfo bakerCtx handlerCtx unliftSko return initSkovData let initWithBlockState = do logEvent Skov LLTrace $ "Opening tree state: " ++ gscTreeStateDirectory - (lldb :: DatabaseHandlers pv) <- liftIO $ openDatabase gscTreeStateDirectory + (lldb :: DatabaseHandlers store pv) <- liftIO $ openDatabase gscTreeStateDirectory logEvent Skov LLTrace "Opened tree state." let context = InitContext pbsc lldb !initSkovData <- runInitMonad initGS context `onException` liftIO (closeDatabase lldb) return - ( SkovV1Context - { _vcBakerContext = bakerCtx, - _vcPersistentBlockStateContext = pbsc, - _vcDisk = lldb, - _vcHandlers = handlerCtx, - _skovV1TUnliftIO = unliftSkov - }, - SkovV1State - { _v1sSkovData = initSkovData, - _v1sTimer = Nothing, - _notifiedProtocolUpdate = Nothing + NewSkov + { nsContext = + SkovV1Context + { _vcBakerContext = bakerCtx, + _vcPersistentBlockStateContext = pbsc, + _vcDisk = lldb, + _vcHandlers = handlerCtx, + _skovV1TUnliftIO = unliftSkov + }, + nsState = + SkovV1State + { _v1sSkovData = initSkovData, + _v1sTimer = Nothing, + _notifiedProtocolUpdate = Nothing + } } - ) initWithBlockState `onException` liftIO (closeBlobStore pbscBlobStore) -- | Activate the 'SkovV1State' so that it is prepared for active consensus operation. @@ -661,9 +677,9 @@ initialiseNewSkovV1 genData genesisBlockHeightInfo bakerCtx handlerCtx unliftSko -- correctly reflects the state of accounts. It also loads the certified blocks from disk. activateSkovV1State :: ( MonadLogger m, - MonadState (SkovData (MPV m)) m, + MonadState (SkovData (MBSStore m) (MPV m)) m, MonadThrow m, - BlockState m ~ HashedPersistentBlockState (MPV m), + BlockState m ~ HashedPersistentBlockState (MBSStore m) (MPV m), LowLevel.MonadTreeStateStore m, BlockStateStorage m, TimeMonad m, @@ -683,7 +699,7 @@ activateSkovV1State = do logEvent GlobalState LLTrace "Done activating global state" -- | Gracefully close the disk storage used by the skov. -shutdownSkovV1 :: SkovV1Context pv m -> LogIO () +shutdownSkovV1 :: SkovV1Context store pv m -> LogIO () shutdownSkovV1 SkovV1Context{..} = liftIO $ do closeBlobStore (pbscBlobStore _vcPersistentBlockStateContext) closeDatabase _vcDisk @@ -695,7 +711,7 @@ shutdownSkovV1 SkovV1Context{..} = liftIO $ do -- creates a new @HashedPersistentBlockState pv@. -- -- After the migration is carried out then the new block state is flushed to disk --- and the new @SkovData pv@ is created. +-- and the new @SkovData store pv@ is created. -- -- The function returns a pair of ('SkovV1Context', 'SkovV1State') suitable for starting the -- protocol. @@ -703,7 +719,7 @@ shutdownSkovV1 SkovV1Context{..} = liftIO $ do -- Note that this function does not free any resources with respect to the -- skov for the @lastpv@. This is the responsibility of the caller. migrateSkovV1 :: - forall lastpv pv m. + forall laststore lastpv store pv m. ( IsConsensusV1 pv, IsProtocolVersion pv, IsProtocolVersion lastpv @@ -717,31 +733,32 @@ migrateSkovV1 :: -- | The configuration for the new consensus instance. GlobalStateConfig -> -- | The old block state context. - PersistentBlockStateContext lastpv -> + PersistentBlockStateContext laststore lastpv -> -- | The old block state - HashedPersistentBlockState lastpv -> + HashedPersistentBlockState laststore lastpv -> -- | The baker context BakerContext -> -- | The handler context HandlerContext pv m -> -- | The function for unlifting a 'SkovV1T' into 'IO'. -- See documentation for 'SkovV1Context'. - (forall a. SkovV1T pv m a -> IO a) -> + (forall a. SkovV1T store pv m a -> IO a) -> -- | Transaction table to migrate TransactionTable -> -- | Pending transaction table to migrate PendingTransactionTable -> -- | Return back the 'SkovV1Context' and the migrated 'SkovV1State' - LogIO (SkovV1Context pv m, SkovV1State pv) + LogIO (NewSkov store pv m) migrateSkovV1 genesisBlockHeightInfo regenesis migration gsConfig@GlobalStateConfig{..} oldPbsc oldBlockState bakerCtx handlerCtx unliftSkov migrateTT migratePTT = do - pbsc@PersistentBlockStateContext{..} <- newPersistentBlockStateContext True gsConfig + pbsc@PersistentBlockStateContext{..} :: PersistentBlockStateContext store pv <- + newPersistentBlockStateContext True gsConfig logEvent GlobalState LLDebug "Migrating existing global state." - let newInitialBlockState :: InitMonad pv (HashedPersistentBlockState pv) + let newInitialBlockState :: InitMonad store pv (HashedPersistentBlockState store pv) newInitialBlockState = flip runBlobStoreT oldPbsc . flip runBlobStoreT pbsc $ do - newState <- migratePersistentBlockState migration $ hpbsPointers oldBlockState + newState <- migratePersistentBlockState migration (hpbsPointers oldBlockState) hashBlockState newState let - initGS :: InitMonad pv (SkovData pv) + initGS :: InitMonad store pv (SkovData store pv) initGS = do newState <- newInitialBlockState stateRef <- saveBlockState newState @@ -761,24 +778,27 @@ migrateSkovV1 genesisBlockHeightInfo regenesis migration gsConfig@GlobalStateCon runDiskLLDBM $ initialiseLowLevelDB storedGenesis (initSkovData ^. persistentRoundStatus) return initSkovData let initWithBlockState = do - (lldb :: DatabaseHandlers pv) <- liftIO $ openDatabase gscTreeStateDirectory + (lldb :: DatabaseHandlers store pv) <- liftIO $ openDatabase gscTreeStateDirectory let context = InitContext pbsc lldb logEvent GlobalState LLDebug "Initializing new tree state." !initSkovData <- runInitMonad initGS context `onException` liftIO (closeDatabase lldb) return - ( SkovV1Context - { _vcBakerContext = bakerCtx, - _vcPersistentBlockStateContext = pbsc, - _vcDisk = lldb, - _vcHandlers = handlerCtx, - _skovV1TUnliftIO = unliftSkov - }, - SkovV1State - { _v1sSkovData = initSkovData, - _v1sTimer = Nothing, - _notifiedProtocolUpdate = Nothing + NewSkov + { nsContext = + SkovV1Context + { _vcBakerContext = bakerCtx, + _vcPersistentBlockStateContext = pbsc, + _vcDisk = lldb, + _vcHandlers = handlerCtx, + _skovV1TUnliftIO = unliftSkov + }, + nsState = + SkovV1State + { _v1sSkovData = initSkovData, + _v1sTimer = Nothing, + _notifiedProtocolUpdate = Nothing + } } - ) initWithBlockState `onException` liftIO (closeBlobStore pbscBlobStore) -- | Make a new 'PersistentBlockStateContext' based on the @@ -794,7 +814,7 @@ newPersistentBlockStateContext :: -- for constructing the persistent block state context. GlobalStateConfig -> -- | The the persistent block state context. - m (PersistentBlockStateContext pv) + m (PersistentBlockStateContext store pv) newPersistentBlockStateContext initialize GlobalStateConfig{..} = liftIO $ do pbscBlobStore <- if initialize then createBlobStore gscBlockStateFile else loadBlobStore gscBlockStateFile pbscAccountCache <- newAccountCache $ rpAccountsCacheSize gscRuntimeParameters diff --git a/concordium-consensus/src/Concordium/KonsensusV1/TestMonad.hs b/concordium-consensus/src/Concordium/KonsensusV1/TestMonad.hs index 1ea905ac51..37145d2fac 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/TestMonad.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/TestMonad.hs @@ -57,44 +57,47 @@ import Concordium.Types.HashableTo import Concordium.Types.Parameters hiding (getChainParameters) -- | Context used for running the 'TestMonad'. -data TestContext (pv :: ProtocolVersion) = TestContext +data TestContext store (pv :: ProtocolVersion) = TestContext { -- | The baker context (i.e. baker keys if any). _tcBakerContext :: !BakerContext, -- | Blob store and caches used by the block state storage. - _tcPersistentBlockStateContext :: PersistentBlockStateContext pv, + _tcPersistentBlockStateContext :: PersistentBlockStateContext store pv, -- | In-memory low-level tree state database. - _tcMemoryLLDB :: !(IORef (LowLevelDB pv)), + _tcMemoryLLDB :: !(IORef (LowLevelDB store pv)), -- | The current time (reported by 'currentTime'). _tcCurrentTime :: !UTCTime } -instance HasBlobStore (TestContext pv) where +instance HasBlobStore store (TestContext store pv) where blobStore = blobStore . _tcPersistentBlockStateContext blobLoadCallback = blobLoadCallback . _tcPersistentBlockStateContext blobStoreCallback = blobStoreCallback . _tcPersistentBlockStateContext -instance (AccountVersionFor pv ~ av) => Cache.HasCache (AccountCache av) (TestContext pv) where +instance + (AccountVersionFor pv ~ av) => + Cache.HasCache (AccountCache store av) (TestContext store pv) + where projectCache = Cache.projectCache . _tcPersistentBlockStateContext -instance Cache.HasCache Module.ModuleCache (TestContext pv) where +instance Cache.HasCache (Module.ModuleCache store) (TestContext store pv) where projectCache = Cache.projectCache . _tcPersistentBlockStateContext -instance HasMemoryLLDB pv (TestContext pv) where +instance HasMemoryLLDB store pv (TestContext store pv) where theMemoryLLDB = _tcMemoryLLDB -instance LMDBAccountMap.HasDatabaseHandlers (TestContext pv) where +instance LMDBAccountMap.HasDatabaseHandlers (TestContext store pv) where databaseHandlers = lens _tcPersistentBlockStateContext (\s v -> s{_tcPersistentBlockStateContext = v}) . LMDBAccountMap.databaseHandlers -- | State used for running the 'TestMonad'. -data TestState pv = TestState +data TestState store pv = TestState { -- | The 'SkovData'. - _tsSkovData :: !(SkovData pv), + _tsSkovData :: !(SkovData store pv), -- | The pending timers. -- The 'Integer' key is a handle for the 'Timer' associated -- with the 'TimerMonad'. - _tsPendingTimers :: !(Map.Map Integer (Timeout, TestMonad pv ())) + _tsPendingTimers :: !(Map.Map Integer (Timeout, TestMonad store pv ())) } -- | Events raised in running the 'TestMonad'. @@ -120,14 +123,16 @@ 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) LogIO +type InnerTestMonad store (pv :: ProtocolVersion) = + RWST (TestContext store pv) (TestWrite pv) (TestState store pv) LogIO -- | This type is used to derive instances of various block state classes for 'TestMonad'. -type PersistentBlockStateMonadHelper pv = +type PersistentBlockStateMonadHelper store pv = PersistentBlockStateMonad + store pv - (TestContext pv) - (InnerTestMonad pv) + (TestContext store pv) + (InnerTestMonad store pv) -- | The 'TestMonad' type itself wraps 'RWST' over 'IO'. -- The reader context is 'TestContext'. @@ -135,16 +140,18 @@ type PersistentBlockStateMonadHelper pv = -- callback from the consensus to an operation of 'MonadTimeout', 'MonadBroadcast', or -- '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), MonadLogger) +newtype TestMonad store (pv :: ProtocolVersion) a = TestMonad {runTestMonad' :: (InnerTestMonad store pv) a} + deriving newtype (Functor, Applicative, Monad, MonadReader (TestContext store pv), MonadIO, MonadThrow, MonadWriter (TestWrite pv), MonadLogger) deriving (BlockStateTypes, ContractStateOperations, ModuleQuery) - via (PersistentBlockStateMonadHelper pv) + via (PersistentBlockStateMonadHelper store pv) + +type instance MBSStore (TestMonad store pv) = store makeLenses ''TestContext makeLenses ''TestState -instance HasBakerContext (TestContext pv) where +instance HasBakerContext (TestContext store pv) where bakerContext = tcBakerContext -- | Project the core genesis data from genesis data for consensus version 1. @@ -158,7 +165,7 @@ 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 store pv a -> IO a runTestMonad _tcBakerContext _tcCurrentTime genData (TestMonad a) = runLog $ runBlobStoreTemp "." $ withNewAccountCacheAndLMDBAccountMap 1000 "accountmap" $ do (genState, genStateRef, initTT, genTimeoutBase, genEpochBakers) <- runPersistentBlockStateMonad $ do @@ -227,68 +234,71 @@ runTestMonad _tcBakerContext _tcCurrentTime genData (TestMonad a) = -- Instances that are required for the 'TestMonad'. deriving via - (PersistentBlockStateMonadHelper pv) + (PersistentBlockStateMonadHelper store pv) instance - (IsProtocolVersion pv) => MonadProtocolVersion (TestMonad pv) + (IsProtocolVersion pv) => MonadProtocolVersion (TestMonad store pv) deriving via - (PersistentBlockStateMonadHelper pv) + (PersistentBlockStateMonadHelper store pv) instance - (IsProtocolVersion pv) => AccountOperations (TestMonad pv) + (IsProtocolVersion pv) => AccountOperations (TestMonad store pv) deriving via - (PersistentBlockStateMonadHelper pv) + (PersistentBlockStateMonadHelper store pv) instance - (IsProtocolVersion pv) => TokenStateOperations StateV1.MutableState (TestMonad pv) + (IsProtocolVersion pv) => + TokenStateOperations (StateV1.MutableState store) (TestMonad store pv) deriving via - (PersistentBlockStateMonadHelper pv) + (PersistentBlockStateMonadHelper store pv) instance - (IsProtocolVersion pv) => PLTQuery (HashedPersistentBlockState pv) StateV1.MutableState (TestMonad pv) + (IsProtocolVersion pv) => + PLTQuery (HashedPersistentBlockState store pv) (StateV1.MutableState store) (TestMonad store pv) deriving via - (PersistentBlockStateMonadHelper pv) + (PersistentBlockStateMonadHelper store pv) instance - (IsProtocolVersion pv) => PLTQuery (PersistentBlockState pv) StateV1.MutableState (TestMonad pv) + (IsProtocolVersion pv) => + PLTQuery (PersistentBlockState store pv) (StateV1.MutableState store) (TestMonad store pv) deriving via - (PersistentBlockStateMonadHelper pv) + (PersistentBlockStateMonadHelper store pv) instance - (IsProtocolVersion pv) => BlockStateQuery (TestMonad pv) + (IsProtocolVersion pv) => BlockStateQuery (TestMonad store pv) deriving via - (PersistentBlockStateMonadHelper pv) + (PersistentBlockStateMonadHelper store pv) instance - (IsProtocolVersion pv) => BlockStateOperations (TestMonad pv) + (IsProtocolVersion pv) => BlockStateOperations (TestMonad store pv) deriving via - (PersistentBlockStateMonadHelper pv) + (PersistentBlockStateMonadHelper store pv) instance - (IsProtocolVersion pv) => BlockStateStorage (TestMonad pv) + (IsProtocolVersion pv) => BlockStateStorage (TestMonad store pv) deriving via - (MemoryLLDBM pv (InnerTestMonad pv)) + (MemoryLLDBM store pv (InnerTestMonad store pv)) instance - (IsProtocolVersion pv) => LowLevel.MonadTreeStateStore (TestMonad pv) + (IsProtocolVersion pv) => LowLevel.MonadTreeStateStore (TestMonad store pv) -instance MonadState (SkovData pv) (TestMonad pv) where +instance MonadState (SkovData store pv) (TestMonad store pv) where state = TestMonad . state . tsSkovData get = TestMonad (use tsSkovData) put = TestMonad . (tsSkovData .=) -instance TimeMonad (TestMonad pv) where +instance TimeMonad (TestMonad store pv) where currentTime = asks _tcCurrentTime -instance MonadTimeout (TestMonad pv) where +instance MonadTimeout (TestMonad store pv) where resetTimer = tell . (: []) . ResetTimer -instance MonadBroadcast (TestMonad pv) where +instance MonadBroadcast (TestMonad store pv) where sendTimeoutMessage = tell . (: []) . SendTimeoutMessage sendQuorumMessage = tell . (: []) . SendQuorumMessage sendBlock = tell . (: []) . SendBlock -instance TimerMonad (TestMonad pv) where - type Timer (TestMonad pv) = Integer +instance TimerMonad (TestMonad store pv) where + type Timer (TestMonad store pv) = Integer onTimeout delay action = TestMonad $ do pts <- use tsPendingTimers let newIndex = case Map.lookupMax pts of @@ -298,14 +308,14 @@ instance TimerMonad (TestMonad pv) where return newIndex cancelTimer timer = TestMonad $ tsPendingTimers %= Map.delete timer -instance MonadConsensusEvent (TestMonad pv) where +instance MonadConsensusEvent (TestMonad store pv) where onBlock = tell . (: []) . OnBlock . bpBlock onFinalize fe _ = tell [OnFinalize fe] -- | Get the currently-pending timers. -getPendingTimers :: TestMonad pv (Map.Map Integer (Timeout, TestMonad pv ())) +getPendingTimers :: TestMonad store pv (Map.Map Integer (Timeout, TestMonad store pv ())) getPendingTimers = TestMonad (gets _tsPendingTimers) -- | Clear all currently-pending timers. -clearPendingTimers :: TestMonad pv () +clearPendingTimers :: TestMonad store pv () clearPendingTimers = TestMonad (modify (\s -> s{_tsPendingTimers = Map.empty})) diff --git a/concordium-consensus/src/Concordium/KonsensusV1/Transactions.hs b/concordium-consensus/src/Concordium/KonsensusV1/Transactions.hs index 65e7417f29..c1b7cf8d15 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/Transactions.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/Transactions.hs @@ -31,6 +31,7 @@ import Concordium.Types.Updates (uiHeader, uiPayload, updateType) import Concordium.Utils import Concordium.GlobalState.BlockState +import Concordium.GlobalState.Persistent.BlobStore (MBSStore) import qualified Concordium.GlobalState.Persistent.BlockState as PBS import qualified Concordium.GlobalState.TransactionTable as TT import Concordium.GlobalState.Transactions @@ -49,6 +50,8 @@ newtype AccountNonceQueryT (m :: Type -> Type) (a :: Type) = AccountNonceQueryT deriving (Functor, Applicative, Monad, MonadIO, TimeMonad, MonadState s, MonadReader r, MonadCatch, MonadThrow) deriving (MonadTrans) via IdentityT +type instance MBSStore (AccountNonceQueryT m) = MBSStore m + -- Instance for deducing the protocol version from the parameterized @m@ of the 'AccountNonceQueryT'. deriving via (MGSTrans AccountNonceQueryT m) instance (MonadProtocolVersion m) => MonadProtocolVersion (AccountNonceQueryT m) @@ -64,8 +67,8 @@ deriving via (MGSTrans AccountNonceQueryT m) instance (ModuleQuery m) => ModuleQ -- | The instance used for acquiring the next available account nonce with respect to consensus protocol v1. instance ( BlockStateQuery m, - GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MPV m), - MonadState (Impl.SkovData (MPV m)) m + GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MBSStore m) (MPV m), + MonadState (Impl.SkovData (MBSStore m) (MPV m)) m ) => AccountNonceQuery (AccountNonceQueryT m) where @@ -75,8 +78,8 @@ instance -- | Verify a block item. This wraps 'TVer.verify'. verifyBlockItem :: ( BlockStateQuery m, - GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MPV m), - MonadState (Impl.SkovData (MPV m)) m + GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MBSStore m) (MPV m), + MonadState (Impl.SkovData (MBSStore m) (MPV m)) m ) => -- | Block time (if transaction is in a block) or current time. Timestamp -> @@ -110,10 +113,10 @@ verifyBlockItem ts bi ctx = runAccountNonceQueryT (runTransactionVerifierT (TVer -- -- This is an internal function only and should not be called directly. addPendingTransaction :: - ( MonadState (Impl.SkovData (MPV m)) m, + ( MonadState (Impl.SkovData (MBSStore m) (MPV m)) m, TimeMonad m, BlockStateQuery m, - GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MPV m) + GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MBSStore m) (MPV m) ) => -- | The transaction. BlockItem -> @@ -147,10 +150,10 @@ addPendingTransaction bi = do -- Return the resulting 'AddBlockItemResult'. processBlockItem :: ( IsConsensusV1 (MPV m), - MonadState (Impl.SkovData (MPV m)) m, + MonadState (Impl.SkovData (MBSStore m) (MPV m)) m, TimeMonad m, BlockStateQuery m, - GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MPV m) + GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MBSStore m) (MPV m) ) => -- | The transaction we want to put into the state. BlockItem -> @@ -200,8 +203,8 @@ processBlockItem bi = do -- This does not add the transaction to the transaction table, or otherwise modify the state. preverifyTransaction :: ( BlockStateQuery m, - MonadState (Impl.SkovData (MPV m)) m, - GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MPV m), + MonadState (Impl.SkovData (MBSStore m) (MPV m)) m, + GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MBSStore m) (MPV m), IsConsensusV1 (MPV m), TimeMonad m ) => @@ -228,8 +231,8 @@ preverifyTransaction bi = -- | Add a transaction to the transaction table that has already been successfully verified. addPreverifiedTransaction :: ( BlockStateQuery m, - MonadState (Impl.SkovData (MPV m)) m, - GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MPV m), + MonadState (Impl.SkovData (MBSStore m) (MPV m)) m, + GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MBSStore m) (MPV m), TimeMonad m ) => BlockItem -> @@ -269,16 +272,16 @@ addPreverifiedTransaction bi okRes = do processBlockItems :: forall m pv. ( IsConsensusV1 pv, - MonadState (Impl.SkovData pv) m, + MonadState (Impl.SkovData (MBSStore m) pv) m, BlockStateQuery m, TimeMonad m, MPV m ~ pv, - GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MPV m) + GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MBSStore m) (MPV m) ) => -- | The baked block BakedBlock pv -> -- | Pointer to the parent block. - BlockPointer pv -> + BlockPointer (MBSStore m) pv -> -- | Return 'True' only if all transactions were -- successfully processed otherwise 'False'. m (Maybe [(BlockItem, TVer.VerificationResult)]) @@ -302,7 +305,7 @@ processBlockItems bb parentPointer = do theTime = bbTimestamp bb -- Process a transaction process :: - Context (PBS.HashedPersistentBlockState pv) -> + Context (PBS.HashedPersistentBlockState (MBSStore m) pv) -> BlockItem -> ContT (Maybe r) m (BlockItem, TVer.VerificationResult) process verificationContext bi = ContT $ \continue -> do diff --git a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/Implementation.hs b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/Implementation.hs index c08d7f577e..349c2829ae 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/Implementation.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/Implementation.hs @@ -82,7 +82,7 @@ instance Exception TreeStateInvariantViolation where -- either alive or pending. -- Furthermore it holds a fixed size cache of hashes -- of blocks marked as dead. -data BlockTable pv = BlockTable +data BlockTable store pv = BlockTable { -- | Cache for dead blocks. -- See documentation of 'DeadCache' for an -- elaborate description of it. @@ -103,20 +103,20 @@ data BlockTable pv = BlockTable -- * When a block is being marked as dead. -- -- Note that non-finalized certified blocks exist both in the live map and on the disk. - _liveMap :: !(HM.HashMap BlockHash (BlockPointer pv)) + _liveMap :: !(HM.HashMap BlockHash (BlockPointer store pv)) } deriving (Show) makeLenses ''BlockTable -instance ToProto (BlockTable pv) where - type Output (BlockTable pv) = Proto.BlockTableSummary +instance ToProto (BlockTable store pv) where + type Output (BlockTable store pv) = Proto.BlockTableSummary toProto BlockTable{..} = Proto.make $ do ProtoFields.deadBlockCacheSize .= fromIntegral (deadCacheCurrentSize _deadBlocks) ProtoFields.liveBlocks .= fmap toProto (HM.keys _liveMap) -- | Create the empty block table. -emptyBlockTable :: BlockTable pv +emptyBlockTable :: BlockTable store pv emptyBlockTable = BlockTable emptyDeadCache HM.empty -- | The 'PendingTransactions' consists of a "focus block", which is a live block, and a pending @@ -133,14 +133,14 @@ emptyBlockTable = BlockTable emptyDeadCache HM.empty -- -- Hence, it must always be the case that a nonce from the perspective of the focus block -- is the same as recorded in the 'PendingTransactionTable'. -data PendingTransactions pv = PendingTransactions +data PendingTransactions store pv = PendingTransactions { -- | The block with respect to which the pending transactions are considered pending. - _focusBlock :: !(BlockPointer pv), + _focusBlock :: !(BlockPointer store pv), -- | The table of pending transactions with respect to the focus block. _pendingTransactionTable :: !TT.PendingTransactionTable } --- We make it classy such that we can provide an instance @HasPendingTransactions (SkovData pv) pv@ +-- We make it classy such that we can provide an instance @HasPendingTransactions (SkovData store pv) pv@ -- making it easier to work with from a 'SkovData' context. makeClassy ''PendingTransactions @@ -158,7 +158,7 @@ makeClassy ''PendingTransactions -- * The current epoch is at least the epoch of every live or finalized block. -- -- * The current round is at least the round of every live or finalized block. -data SkovData (pv :: ProtocolVersion) = SkovData +data SkovData store (pv :: ProtocolVersion) = SkovData { -- | Status for the current round that is persisted to the low-level database. -- This is used to record when we have signed messages to ensure that we avoid double -- signing across node restarts. @@ -166,7 +166,7 @@ data SkovData (pv :: ProtocolVersion) = SkovData -- | The round status which holds data -- associated with the current round of the -- consensus protocol. - _roundStatus :: !(RoundStatus pv), + _roundStatus :: !(RoundStatus store pv), -- | Transactions. -- The transaction table tracks the following: -- * Live transactions: mapping from a 'TransactionHash' to the status of the transaction, @@ -179,13 +179,13 @@ data SkovData (pv :: ProtocolVersion) = SkovData -- | The purge counter for the 'TransactionTable' _transactionTablePurgeCounter :: !Int, -- | Pending transactions - _skovPendingTransactions :: !(PendingTransactions pv), + _skovPendingTransactions :: !(PendingTransactions store pv), -- | Runtime parameters. _runtimeParameters :: !RuntimeParameters, -- | Blocks which have been included in the tree or marked as dead. - _blockTable :: !(BlockTable pv), + _blockTable :: !(BlockTable store pv), -- | Branches of the tree ordered by height above the last finalized block - _branches :: !(Seq.Seq [BlockPointer pv]), + _branches :: !(Seq.Seq [BlockPointer store pv]), -- | For non-finalized rounds, tracks which bakers we have seen legally-signed blocks with -- live parent blocks from. This is used for duplicate detection. _roundExistingBlocks :: !(Map.Map Round (Map.Map BakerId BlockSignatureWitness)), @@ -197,7 +197,7 @@ data SkovData (pv :: ProtocolVersion) = SkovData -- | Block height information of the (current) genesis block. _genesisBlockHeight :: !GenesisBlockHeightInfo, -- | Pointer to the last finalized block. - _lastFinalized :: !(BlockPointer pv), + _lastFinalized :: !(BlockPointer store pv), -- | A finalization entry that finalizes the last finalized block, unless that is the -- genesis block. _latestFinalizationEntry :: !(Option (FinalizationEntry pv)), @@ -218,21 +218,21 @@ data SkovData (pv :: ProtocolVersion) = SkovData -- may or may not be finalized explicitly, but such a block is uniquely determined -- across all nodes. (Note that the ultimate last finalized block may not be uniquely -- determined, because some rounds could have both QCs and TCs.) - _terminalBlock :: !(Option (BlockPointer pv)) + _terminalBlock :: !(Option (BlockPointer store pv)) } makeLenses ''SkovData -instance HasPendingTransactions (SkovData pv) pv where +instance HasPendingTransactions (SkovData store pv) store pv where pendingTransactions = skovPendingTransactions {-# INLINE pendingTransactions #-} -instance HasEpochBakers (SkovData pv) where +instance HasEpochBakers (SkovData store pv) where epochBakers = skovEpochBakers {-# INLINE epochBakers #-} -instance ToProto (SkovData pv) where - type Output (SkovData pv) = Proto.ConsensusDetailedStatus +instance ToProto (SkovData store pv) where + type Output (SkovData store pv) = Proto.ConsensusDetailedStatus toProto sd = Proto.make $ do ProtoFields.genesisBlock .= toProto (sd ^. currentGenesisHash) ProtoFields.persistentRoundStatus .= toProto (sd ^. persistentRoundStatus) @@ -269,38 +269,38 @@ instance ToProto (SkovData pv) where (sd ^. terminalBlock) -- | Getter for accessing the genesis hash for the current genesis. -currentGenesisHash :: SimpleGetter (SkovData pv) BlockHash +currentGenesisHash :: SimpleGetter (SkovData store pv) BlockHash currentGenesisHash = genesisMetadata . to gmCurrentGenesisHash -- | Whether consensus is shutdown. -- This is @True@ when: -- * A protocol update was effective in the trigger block in this epoch. -- * The trigger block is finalized. -isConsensusShutdown :: SimpleGetter (SkovData pv) Bool +isConsensusShutdown :: SimpleGetter (SkovData store pv) Bool isConsensusShutdown = terminalBlock . to isPresent -- | Run the given action unless the consensus is already shut down. -unlessShutdown :: (MonadState (SkovData pv) m) => m () -> m () +unlessShutdown :: (MonadState (SkovData store pv) m) => m () -> m () unlessShutdown a = do isShutdown <- use isConsensusShutdown unless isShutdown a -- | Lens for accessing the witness that a baker signed a block in a particular round. -roundBakerExistingBlock :: Round -> BakerId -> Lens' (SkovData pv) (Maybe BlockSignatureWitness) +roundBakerExistingBlock :: Round -> BakerId -> Lens' (SkovData store pv) (Maybe BlockSignatureWitness) roundBakerExistingBlock rnd bakerId = roundExistingBlocks . at' rnd . nonEmpty . at' bakerId -- | Remove all entries from 'roundExistingBlocks' with round less than or equal to the supplied -- round. -purgeRoundExistingBlocks :: (MonadState (SkovData pv) m) => Round -> m () +purgeRoundExistingBlocks :: (MonadState (SkovData store pv) m) => Round -> m () purgeRoundExistingBlocks rnd = roundExistingBlocks %=! snd . Map.split rnd -- | Lens for accessing the witness that we have checked a 'QuorumCertificate' for a particular 'Round'. -roundExistingQuorumCertificate :: Round -> Lens' (SkovData pv) (Maybe QuorumCertificateCheckedWitness) +roundExistingQuorumCertificate :: Round -> Lens' (SkovData store pv) (Maybe QuorumCertificateCheckedWitness) roundExistingQuorumCertificate rnd = roundExistingQCs . at' rnd -- | Record that we have checked a 'QuorumCertificate' in the 'roundExistingQCs'. -- The certificate should be for a round that is later than the last finalized round. -recordCheckedQuorumCertificate :: (MonadState (SkovData pv) m) => QuorumCertificate -> m () +recordCheckedQuorumCertificate :: (MonadState (SkovData store pv) m) => QuorumCertificate -> m () recordCheckedQuorumCertificate qc = roundExistingQuorumCertificate (qcRound qc) ?=! witness where @@ -308,11 +308,11 @@ recordCheckedQuorumCertificate qc = -- | Remove all entries from 'roundExistingQCs' with a 'Round' less than to the -- supplied 'Round'. -purgeRoundExistingQCs :: (MonadState (SkovData pv) m) => Round -> m () +purgeRoundExistingQCs :: (MonadState (SkovData store pv) m) => Round -> m () purgeRoundExistingQCs rnd = roundExistingQCs %=! snd . Map.split (rnd - 1) --- | Create an initial 'SkovData pv' --- This constructs a 'SkovData pv' from a genesis block +-- | Create an initial 'SkovData store pv' +-- This constructs a 'SkovData store pv' from a genesis block -- which is suitable to grow the tree from. -- -- In the case that this is from a genesis, then an empty transaction table @@ -327,7 +327,7 @@ purgeRoundExistingQCs rnd = roundExistingQCs %=! snd . Map.split (rnd - 1) -- * The caller must make sure, that the supplied 'TransactionTable' does NOT contain any @Committed@ transactions -- and all transactions have their commit point set to 0. mkInitialSkovData :: - forall pv. + forall store pv. (IsProtocolVersion pv) => -- | The 'RuntimeParameters' RuntimeParameters -> @@ -336,7 +336,7 @@ mkInitialSkovData :: -- | Block height information for the genesis block. GenesisBlockHeightInfo -> -- | Genesis state - PBS.HashedPersistentBlockState pv -> + PBS.HashedPersistentBlockState store pv -> -- | The base timeout Duration -> -- | Bakers at the genesis block @@ -346,7 +346,7 @@ mkInitialSkovData :: -- | 'PendingTransactionTable' to initialize the 'SkovData' with. TT.PendingTransactionTable -> -- | The initial 'SkovData' - SkovData pv + SkovData store pv mkInitialSkovData rp genMeta genesisBlockHeightInfo genState _currentTimeout _skovEpochBakers transactionTable' pendingTransactionTable' = let genesisBlock = GenesisBlock genMeta genesisTime = timestampToUTCTime $ Base.genesisTime (gmParameters genMeta) @@ -398,12 +398,12 @@ mkInitialSkovData rp genMeta genesisBlockHeightInfo genState _currentTimeout _sk -- | Get the 'BlockPointer' for a block hash that is live (not finalized). -- Returns 'Nothing' if the block is not in the live (non-finalized) blocks. -getLiveBlock :: BlockHash -> SkovData pv -> Maybe (BlockPointer pv) +getLiveBlock :: BlockHash -> SkovData store pv -> Maybe (BlockPointer store pv) getLiveBlock blockHash sd = sd ^? blockTable . liveMap . ix blockHash -- | Get the 'BlockPointer' for a block hash that is live or the last finalized block. -- Returns 'Nothing' if the block is neither live nor the last finalized block. -getLiveOrLastFinalizedBlock :: BlockHash -> SkovData pv -> Maybe (BlockPointer pv) +getLiveOrLastFinalizedBlock :: BlockHash -> SkovData store pv -> Maybe (BlockPointer store pv) getLiveOrLastFinalizedBlock blockHash sd | blockHash == getHash (sd ^. lastFinalized) = Just $! sd ^. lastFinalized | otherwise = getLiveBlock blockHash sd @@ -415,7 +415,7 @@ getLiveOrLastFinalizedBlock blockHash sd -- 'Just BlockStatus'. -- This function should not be called directly, instead use either -- 'getBlockStatus' or 'getRecentBlockStatus'. -getMemoryBlockStatus :: BlockHash -> SkovData pv -> Maybe (BlockStatus pv) +getMemoryBlockStatus :: BlockHash -> SkovData store pv -> Maybe (BlockStatus store pv) getMemoryBlockStatus blockHash sd -- Check if it's last finalized | getHash (sd ^. lastFinalized) == blockHash = Just $! BlockFinalized (sd ^. lastFinalized) @@ -429,7 +429,7 @@ getMemoryBlockStatus blockHash sd | otherwise = Nothing -- | Create a block pointer from a stored block. -mkBlockPointer :: (MonadIO m) => LowLevel.StoredBlock pv -> m (BlockPointer pv) +mkBlockPointer :: (MonadIO m) => LowLevel.StoredBlock store pv -> m (BlockPointer store pv) mkBlockPointer sb@LowLevel.StoredBlock{..} = do bpState <- liftIO mkHashedPersistentBlockState return BlockPointer{bpInfo = stbInfo, bpBlock = stbBlock, ..} @@ -442,7 +442,9 @@ mkBlockPointer sb@LowLevel.StoredBlock{..} = do -- | Get the 'BlockStatus' of a block based on the provided 'BlockHash'. -- Note. if one does not care about old finalized blocks then -- use 'getRecentBlockStatus' instead as it circumvents a full lookup from disk. -getBlockStatus :: (LowLevel.MonadTreeStateStore m, MonadIO m) => BlockHash -> SkovData (MPV m) -> m (BlockStatus (MPV m)) +getBlockStatus :: + (LowLevel.MonadTreeStateStore m, MonadIO m) => + BlockHash -> SkovData (BlobStore.MBSStore m) (MPV m) -> m (BlockStatus (BlobStore.MBSStore m) (MPV m)) getBlockStatus blockHash sd = case getMemoryBlockStatus blockHash sd of Just bs -> return bs Nothing -> @@ -455,7 +457,9 @@ getBlockStatus blockHash sd = case getMemoryBlockStatus blockHash sd of -- | Get the 'RecentBlockStatus' of a block based on the provided 'BlockHash'. -- Use this instead of 'getBlockStatus' if the contents and resulting state are not needed -- for blocks beyond the last finalized block. -getRecentBlockStatus :: (LowLevel.MonadTreeStateStore m) => BlockHash -> SkovData (MPV m) -> m (RecentBlockStatus (MPV m)) +getRecentBlockStatus :: + (LowLevel.MonadTreeStateStore m) => + BlockHash -> SkovData store (MPV m) -> m (RecentBlockStatus store (MPV m)) getRecentBlockStatus blockHash sd = case getMemoryBlockStatus blockHash sd of Just bs -> return $! RecentBlock bs Nothing -> do @@ -465,7 +469,9 @@ getRecentBlockStatus blockHash sd = case getMemoryBlockStatus blockHash sd of -- | Get a finalized block by height. -- This will return 'Nothing' for a block that is either not finalized or unknown. -getFinalizedBlockAtHeight :: (LowLevel.MonadTreeStateStore m, MonadIO m) => BlockHeight -> m (Maybe (BlockPointer (MPV m))) +getFinalizedBlockAtHeight :: + (LowLevel.MonadTreeStateStore m, MonadIO m) => + BlockHeight -> m (Maybe (BlockPointer (BlobStore.MBSStore m) (MPV m))) getFinalizedBlockAtHeight height = do LowLevel.lookupBlockByHeight height >>= \case Nothing -> return Nothing @@ -477,8 +483,8 @@ getFinalizedBlockAtHeight height = do getBlocksAtHeight :: (LowLevel.MonadTreeStateStore m, MonadIO m) => BlockHeight -> - SkovData (MPV m) -> - m [BlockPointer (MPV m)] + SkovData (BlobStore.MBSStore m) (MPV m) -> + m [BlockPointer (BlobStore.MBSStore m) (MPV m)] getBlocksAtHeight height sd = case compare height lastFinHeight of LT -> toList <$> getFinalizedBlockAtHeight height EQ -> return [sd ^. lastFinalized] @@ -492,9 +498,9 @@ getBlocksAtHeight height sd = case compare height lastFinHeight of getFirstFinalizedBlockOfEpoch :: (LowLevel.MonadTreeStateStore m, MonadIO m) => -- | Target epoch or a block in the target epoch. - Either Epoch (BlockPointer (MPV m)) -> - SkovData (MPV m) -> - m (Maybe (BlockPointer (MPV m))) + Either Epoch (BlockPointer (BlobStore.MBSStore m) (MPV m)) -> + SkovData (BlobStore.MBSStore m) (MPV m) -> + m (Maybe (BlockPointer (BlobStore.MBSStore m) (MPV m))) getFirstFinalizedBlockOfEpoch epochOrBlock sd | targetEpoch > blockEpoch lastFin = return Nothing | otherwise = do @@ -522,17 +528,17 @@ getFirstFinalizedBlockOfEpoch epochOrBlock sd -- The hash of the block state MUST match the block state hash of the block; this is not checked. -- [Note: this does not affect the '_branches' of the 'SkovData'.] makeLiveBlock :: - forall m pv. - (MonadState (SkovData pv) m, IsProtocolVersion pv) => + forall m store pv. + (MonadState (SkovData store pv) m, IsProtocolVersion pv) => -- | Pending block to make live PendingBlock pv -> -- | Block state associated with the block - PBS.HashedPersistentBlockState pv -> + PBS.HashedPersistentBlockState store pv -> BlockHeight -> UTCTime -> -- | Energy used in executing the block Energy -> - m (BlockPointer pv) + m (BlockPointer store pv) makeLiveBlock pb st height arriveTime energyCost = do let bp = BlockPointer @@ -558,7 +564,7 @@ makeLiveBlock pb st height arriveTime energyCost = do -- This expunges the block from memory -- and registers the block in the dead cache. -- [Note: this does not affect the '_branches' of the 'SkovData'.] -markBlockDead :: (MonadState (SkovData pv) m) => BlockHash -> m () +markBlockDead :: (MonadState (SkovData store pv) m) => BlockHash -> m () markBlockDead blockHash = do blockTable . liveMap . at' blockHash .=! Nothing blockTable . deadBlocks %=! insertDeadCache blockHash @@ -567,11 +573,11 @@ markBlockDead blockHash = do -- transaction table by purging all transaction outcomes that refer to this block. -- [Note: this does not affect the '_branches' of the 'SkovData'.] markLiveBlockDead :: - ( MonadState (SkovData pv) m, + ( MonadState (SkovData store pv) m, BlockStateStorage m, - GSTypes.BlockState m ~ PBS.HashedPersistentBlockState pv + GSTypes.BlockState m ~ PBS.HashedPersistentBlockState store pv ) => - BlockPointer pv -> + BlockPointer store pv -> m () markLiveBlockDead bp = do let bh = getHash bp @@ -583,10 +589,10 @@ markLiveBlockDead bp = do -- This removes them the in-memory transaction table. -- The caller is expected to ensure that they are written to the low-level storage. markLiveBlocksFinal :: - (MonadState (SkovData pv) m) => + (MonadState (SkovData store pv) m) => -- | Blocks to mark final i.e. removing them from the live block map. -- Note that the order of the blocks does not matter for this operation. - [BlockPointer pv] -> + [BlockPointer store pv] -> m () markLiveBlocksFinal blockPointers = blockTable @@ -598,9 +604,9 @@ markLiveBlocksFinal blockPointers = -- Note that it is assumed that the parent is either live or finalized as otherwise this -- function will raise an error. parentOf :: - (LowLevel.MonadTreeStateStore m, MonadIO m, MonadState (SkovData (MPV m)) m) => - BlockPointer (MPV m) -> - m (BlockPointer (MPV m)) + (LowLevel.MonadTreeStateStore m, MonadIO m, MonadState (SkovData (BlobStore.MBSStore m) (MPV m)) m) => + BlockPointer (BlobStore.MBSStore m) (MPV m) -> + m (BlockPointer (BlobStore.MBSStore m) (MPV m)) parentOf block | Present blockData <- blockBakedData block = do get >>= getBlockStatus (blockParent blockData) <&> \case @@ -618,7 +624,7 @@ parentOf block -- By definition, the parent block must either also be live or be the last finalized block. -- -- If the block is not live, this function may fail with an error. -parentOfLive :: (HasCallStack) => SkovData pv -> BlockPointer pv -> BlockPointer pv +parentOfLive :: (HasCallStack) => SkovData store pv -> BlockPointer store pv -> BlockPointer store pv parentOfLive sd block | let lastFin = sd ^. lastFinalized, parentHash == getHash lastFin = @@ -639,7 +645,9 @@ parentOfLive sd block -- | Get the parent of a block where the parent is a finalized block. -- This will produce an error if the supplied block is the genesis block, or the parent block is -- not finalized. -parentOfFinalized :: (LowLevel.MonadTreeStateStore m, MonadIO m) => BlockPointer (MPV m) -> m (BlockPointer (MPV m)) +parentOfFinalized :: + (LowLevel.MonadTreeStateStore m, MonadIO m) => + BlockPointer (BlobStore.MBSStore m) (MPV m) -> m (BlockPointer (BlobStore.MBSStore m) (MPV m)) parentOfFinalized block = do let parentHash | Present blockData <- blockBakedData block = blockParent blockData @@ -661,9 +669,9 @@ parentOfFinalized block = do -- to pass 1 day if we need to go back 50 blocks, and 1 billion years if we need to go back 200 -- blocks. lastFinalizedOf :: - (LowLevel.MonadTreeStateStore m, MonadIO m, MonadState (SkovData (MPV m)) m) => - BlockPointer (MPV m) -> - m (BlockPointer (MPV m)) + (LowLevel.MonadTreeStateStore m, MonadIO m, MonadState (SkovData (BlobStore.MBSStore m) (MPV m)) m) => + BlockPointer (BlobStore.MBSStore m) (MPV m) -> + m (BlockPointer (BlobStore.MBSStore m) (MPV m)) lastFinalizedOf = go <=< parentOf where go block @@ -677,11 +685,11 @@ lastFinalizedOf = go <=< parentOf -- | Determine if one block is an ancestor of another. -- A block is considered to be an ancestor of itself. isAncestorOf :: - (LowLevel.MonadTreeStateStore m, MonadIO m, MonadState (SkovData (MPV m)) m) => + (LowLevel.MonadTreeStateStore m, MonadIO m, MonadState (SkovData (BlobStore.MBSStore m) (MPV m)) m) => -- | The block to check whether it's an ancestor of the other or not. - BlockPointer (MPV m) -> + BlockPointer (BlobStore.MBSStore m) (MPV m) -> -- | The block to carry out the ancestor check with respect to. - BlockPointer (MPV m) -> + BlockPointer (BlobStore.MBSStore m) (MPV m) -> m Bool isAncestorOf b1 maybeAncestor = case compare (blockHeight b1) (blockHeight maybeAncestor) of GT -> return False @@ -701,9 +709,9 @@ isAncestorOf b1 maybeAncestor = case compare (blockHeight b1) (blockHeight maybe -- The latter note is enforced by the way we add pending blocks, i.e. pending blocks are awaiting -- their parent before becoming live. addToBranches :: - (MonadState (SkovData pv) m) => + (MonadState (SkovData store pv) m) => -- | The block to add to the current branches. - BlockPointer pv -> + BlockPointer store pv -> m () addToBranches block = do lfbHeight <- use $ lastFinalized . to blockHeight @@ -719,7 +727,7 @@ addToBranches block = do -- | Get the blocks in the branches of the tree grouped by descending height. -- That is the first element of the list is all of the blocks at 'getCurrentHeight', -- the next is those at @getCurrentHeight - 1@, etc. -branchesFromTop :: SkovData pv -> [[BlockPointer pv]] +branchesFromTop :: SkovData store pv -> [[BlockPointer store pv]] branchesFromTop = revSeqToList . _branches where revSeqToList Seq.Empty = [] @@ -729,12 +737,12 @@ branchesFromTop = revSeqToList . _branches -- | Lookup a transaction in the transaction table if it is live. -- This will give a 'Nothing' result for finalized transactions. -lookupLiveTransaction :: TransactionHash -> SkovData pv -> Maybe TT.LiveTransactionStatus +lookupLiveTransaction :: TransactionHash -> SkovData store pv -> Maybe TT.LiveTransactionStatus lookupLiveTransaction tHash sd = sd ^? transactionTable . TT.ttHashMap . at tHash . traversed . _2 -- | Lookup a transaction in the transaction table, including finalized transactions. -lookupTransaction :: (LowLevel.MonadTreeStateStore m) => TransactionHash -> SkovData pv -> m (Maybe TransactionStatus) +lookupTransaction :: (LowLevel.MonadTreeStateStore m) => TransactionHash -> SkovData store pv -> m (Maybe TransactionStatus) lookupTransaction tHash sd = case lookupLiveTransaction tHash sd of Just liveRes -> return $ Just $ Live liveRes Nothing -> fmap Finalized <$> LowLevel.lookupTransaction tHash @@ -750,7 +758,7 @@ getNonFinalizedAccountTransactions :: AccountAddressEq -> -- | Starting nonce. Nonce -> - SkovData pv -> + SkovData store pv -> [(Nonce, Map.Map Transaction TVer.VerificationResult)] getNonFinalizedAccountTransactions addr nnce sd = case sd ^. transactionTable . TT.ttNonFinalizedTransactions . at' addr of @@ -773,7 +781,7 @@ getNonFinalizedChainUpdates :: UpdateType -> -- | The starting sequence number. UpdateSequenceNumber -> - SkovData pv -> + SkovData store pv -> -- | The resulting list of chain updates. [(UpdateSequenceNumber, Map.Map (WithMetadata UpdateInstruction) TVer.VerificationResult)] getNonFinalizedChainUpdates uType updateSequenceNumber sd = do @@ -790,8 +798,8 @@ getNonFinalizedChainUpdates uType updateSequenceNumber sd = do getNonFinalizedCredential :: -- | 'TransactionHash' for the transaction that contained the 'CredentialDeployment'. TransactionHash -> - -- | The 'SkovData pv' to query the non finalized credential from. - SkovData pv -> + -- | The 'SkovData store pv' to query the non finalized credential from. + SkovData store pv -> Maybe (CredentialDeploymentWithMeta, TVer.VerificationResult) getNonFinalizedCredential txhash sd = do case sd ^? transactionTable . TT.ttHashMap . ix txhash of @@ -808,14 +816,14 @@ getNonFinalizedCredential txhash sd = do -- tied to this account. getNextAccountNonce :: ( BlockStateQuery m, - GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MPV m) + GSTypes.BlockState m ~ PBS.HashedPersistentBlockState store (MPV m) ) => -- | The 'AccountAddressEq' to get the next available nonce for. -- This will work for account aliases as this is an 'AccountAddressEq' -- and not just a 'AccountAddress'. AccountAddressEq -> - -- | The 'SkovData pv' to query the next account nonce from. - SkovData (MPV m) -> + -- | The 'SkovData store pv' to query the next account nonce from. + SkovData store (MPV m) -> -- | The resulting account nonce and whether it is finalized or not. m (Nonce, Bool) getNextAccountNonce addr sd = @@ -836,7 +844,7 @@ getNextAccountNonce addr sd = -- nonce. This does not write the transactions to the low-level tree state database, but just -- updates the in-memory transaction table accordingly. finalizeTransactions :: - ( MonadState (SkovData pv) m, + ( MonadState (SkovData store pv) m, MonadThrow m ) => -- | The transactions to remove from the state. @@ -903,7 +911,7 @@ finalizeTransactions = mapM_ removeTrans -- | Mark the (live) transactions for a particular block as committed. -- This does nothing for transactions that are not live. commitTransactions :: - (MonadState (SkovData pv) m) => + (MonadState (SkovData store pv) m) => -- | Round of the block Round -> -- | The 'BlockHash' that the transaction should @@ -929,7 +937,7 @@ commitTransactions rnd bh transactions = transactionTable . TT.ttHashMap %=! doC -- When adding a transaction from a block, use the 'Round' of the block. Otherwise use round @0@. -- The transaction must not already be present. addTransaction :: - (MonadState (SkovData pv) m) => + (MonadState (SkovData store pv) m) => Round -> BlockItem -> TVer.VerificationResult -> @@ -941,7 +949,7 @@ addTransaction rnd transaction verRes = do -- | Mark the provided transaction as dead for the provided 'BlockHash'. markTransactionDead :: - (MonadState (SkovData pv) m) => + (MonadState (SkovData store pv) m) => -- | The 'BlockHash' where the transaction was committed. BlockHash -> -- | The 'BlockItem' to mark as dead. @@ -984,7 +992,7 @@ markTransactionDead blockHash transaction = -- then 'commitTransaction' or 'addCommitTransaction' has been called with a -- slot number at least as high as the slot number of the block. purgeTransactionTable :: - (MonadState (SkovData pv) m) => + (MonadState (SkovData store pv) m) => -- | Whether to force the purging. Bool -> -- | The current time. @@ -1016,10 +1024,10 @@ purgeTransactionTable force currentTime = do -- -- PRECONDITION: The new focus block must be a live block, or the last finalized block. updateFocusBlockTo :: - forall m. - (MonadState (SkovData (MPV m)) m) => + forall store m. + (MonadState (SkovData store (MPV m)) m) => -- | New focus block - BlockPointer (MPV m) -> + BlockPointer store (MPV m) -> m () updateFocusBlockTo newFocusBlock = do -- 'parent' will be a function that gets the parent of live blocks in the present state. @@ -1075,7 +1083,7 @@ updateFocusBlockTo newFocusBlock = do -- Additionally, they may be available for future epochs in the same payday as the last finalized -- block. -- Returns 'Nothing' if the bakers and finalizers are not available. -getBakersForEpoch :: Epoch -> SkovData pv -> Maybe BakersAndFinalizers +getBakersForEpoch :: Epoch -> SkovData store pv -> Maybe BakersAndFinalizers getBakersForEpoch e s | e == curEpoch = Just (s ^. currentEpochBakers) | e == curEpoch + 1 = Just (s ^. nextEpochBakers) @@ -1088,7 +1096,7 @@ getBakersForEpoch e s -- | Get the bakers at the current epoch. -- This relies on the fact that the current epoch is either the same as the epoch of the last -- finalized block, or the next epoch. -bakersForCurrentEpoch :: SkovData pv -> BakersAndFinalizers +bakersForCurrentEpoch :: SkovData store pv -> BakersAndFinalizers bakersForCurrentEpoch sd | sd ^. roundStatus . rsCurrentEpoch == sd ^. lastFinalized . to blockEpoch = sd ^. currentEpochBakers @@ -1102,7 +1110,7 @@ bakersForCurrentEpoch sd -- 'Received' transactions have their 'CommitPoint' reset. -- Transactions that were 'Committed' (to any non-finalized block) have -- their status changed to 'Received' and their 'CommitPoint' is reset. -clearOnProtocolUpdate :: (MonadState (SkovData pv) m) => m () +clearOnProtocolUpdate :: (MonadState (SkovData store pv) m) => m () clearOnProtocolUpdate = do -- clear the block table blockTable .=! emptyBlockTable @@ -1120,7 +1128,7 @@ clearOnProtocolUpdate = do -- | Clear the transaction table and pending transactions, ensure that the block states are archived, -- and collapse the block state caches. -clearAfterProtocolUpdate :: (MonadState (SkovData pv) m, BlockStateStorage m, GSTypes.BlockState m ~ PBS.HashedPersistentBlockState pv) => m () +clearAfterProtocolUpdate :: (MonadState (SkovData store pv) m, BlockStateStorage m, GSTypes.BlockState m ~ PBS.HashedPersistentBlockState store pv) => m () clearAfterProtocolUpdate = do -- Clear the transaction table and pending transactions. transactionTable .=! TT.emptyTransactionTable @@ -1136,12 +1144,14 @@ clearAfterProtocolUpdate = do collapseCaches -- | Sets and persists the 'PersistentRoundStatus' of the 'SkovData'. -setPersistentRoundStatus :: (LowLevel.MonadTreeStateStore m, MonadState (SkovData (MPV m)) m) => PersistentRoundStatus -> m () +setPersistentRoundStatus :: + (LowLevel.MonadTreeStateStore m, MonadState (SkovData store (MPV m)) m) => + PersistentRoundStatus -> m () setPersistentRoundStatus = updatePersistentRoundStatus . const -- | Updates and persists the 'PersistentRoundStatus' of the 'SkovData'. updatePersistentRoundStatus :: - (LowLevel.MonadTreeStateStore m, MonadState (SkovData (MPV m)) m) => + (LowLevel.MonadTreeStateStore m, MonadState (SkovData store (MPV m)) m) => (PersistentRoundStatus -> PersistentRoundStatus) -> m () updatePersistentRoundStatus change = do diff --git a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel.hs b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel.hs index ade3a48979..98776d60f7 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel.hs @@ -17,24 +17,24 @@ import Concordium.KonsensusV1.Types import Concordium.Types.HashableTo -- | A reference to the block state for a particular block. -type BlockStateRef (pv :: ProtocolVersion) = BlobRef (BlockStatePointers pv) +type BlockStateRef store (pv :: ProtocolVersion) = BlobRef store (BlockStatePointers store pv) -- | A stored block as retained by the low-level tree state store. -- Note: we serialize blocks with a version byte to allow future flexibility in how blocks are -- stored. -data StoredBlock (pv :: ProtocolVersion) = StoredBlock +data StoredBlock store (pv :: ProtocolVersion) = StoredBlock { -- | Metadata about the block. stbInfo :: !(BlockMetadata pv), -- | The block itself. stbBlock :: !(Block pv), -- | Pointer to the state in the block state storage. - stbStatePointer :: !(BlockStateRef pv) + stbStatePointer :: !(BlockStateRef store pv) } -type instance BlockProtocolVersion (StoredBlock pv) = pv +type instance BlockProtocolVersion (StoredBlock store pv) = pv -- | Get the block state hash for a stored block. -stbBlockStateHash :: StoredBlock pv -> StateHash +stbBlockStateHash :: StoredBlock store pv -> StateHash stbBlockStateHash storedBlock = -- Prior to P7, the block state hash is stored in the baked block, for P7 and onwards the block -- state hash is stored in the block metadata. @@ -46,7 +46,7 @@ stbBlockStateHash storedBlock = case blockDerivableHashes signedBlock of DerivableBlockHashesV0{..} -> dbhv0BlockStateHash -instance (IsProtocolVersion pv) => Serialize (StoredBlock pv) where +instance (IsProtocolVersion pv) => Serialize (StoredBlock store pv) where put StoredBlock{..} = do putWord8 0 -- Version byte put stbInfo @@ -66,8 +66,8 @@ instance (IsProtocolVersion pv) => Serialize (StoredBlock pv) where return StoredBlock{..} v -> fail $ "Unsupported StoredBlock version: " ++ show v -instance BlockData (StoredBlock pv) where - type BakedBlockDataType (StoredBlock pv) = SignedBlock pv +instance BlockData (StoredBlock store pv) where + type BakedBlockDataType (StoredBlock store pv) = SignedBlock pv blockRound = blockRound . stbBlock blockEpoch = blockEpoch . stbBlock blockTimestamp = blockTimestamp . stbBlock @@ -76,10 +76,10 @@ instance BlockData (StoredBlock pv) where blockTransaction i = blockTransaction i . stbBlock blockTransactionCount = blockTransactionCount . stbBlock -instance HashableTo BlockHash (StoredBlock pv) where +instance HashableTo BlockHash (StoredBlock store pv) where getHash = getHash . stbBlock -instance HasBlockMetadata (StoredBlock pv) where +instance HasBlockMetadata (StoredBlock store pv) where blockMetadata = stbInfo -- | 'MonadTreeStateStore' defines the interface to the low-level tree state database. @@ -97,21 +97,21 @@ instance HasBlockMetadata (StoredBlock pv) where -- * The transactions indexed in the store are exactly the transactions of finalized blocks. class (Monad m) => MonadTreeStateStore m where -- | Get a block by block hash. - lookupBlock :: BlockHash -> m (Maybe (StoredBlock (MPV m))) + lookupBlock :: BlockHash -> m (Maybe (StoredBlock (MBSStore m) (MPV m))) -- | Determine if a block is present in the block table. memberBlock :: BlockHash -> m Bool -- | Get the first (i.e. genesis) block. -- (The implementation can assume that this block has height 0.) - lookupFirstBlock :: m (Maybe (StoredBlock (MPV m))) + lookupFirstBlock :: m (Maybe (StoredBlock (MBSStore m) (MPV m))) lookupFirstBlock = lookupBlockByHeight 0 -- | Get the last finalized block. - lookupLastFinalizedBlock :: m (Maybe (StoredBlock (MPV m))) + lookupLastFinalizedBlock :: m (Maybe (StoredBlock (MBSStore m) (MPV m))) -- | Look up a finalized block by height. - lookupBlockByHeight :: BlockHeight -> m (Maybe (StoredBlock (MPV m))) + lookupBlockByHeight :: BlockHeight -> m (Maybe (StoredBlock (MBSStore m) (MPV m))) -- | Look up a transaction by its hash. lookupTransaction :: TransactionHash -> m (Maybe FinalizedTransactionStatus) @@ -137,7 +137,7 @@ class (Monad m) => MonadTreeStateStore m where -- * The list of blocks is non-empty, consists of consecutive non-finalized blocks -- that form a chain. -- * The finalization entry is for the last of these blocks. - writeFinalizedBlocks :: [StoredBlock (MPV m)] -> FinalizationEntry (MPV m) -> m () + writeFinalizedBlocks :: [StoredBlock (MBSStore m) (MPV m)] -> FinalizationEntry (MPV m) -> m () -- | Write a certified block that does not finalize other blocks. -- This has the following effects: @@ -150,7 +150,7 @@ class (Monad m) => MonadTreeStateStore m where -- * The quorum certificate is for the supplied block. writeCertifiedBlock :: -- | The newly-certified block. - StoredBlock (MPV m) -> + StoredBlock (MBSStore m) (MPV m) -> -- | The quorum certificate for the block. QuorumCertificate -> m () @@ -167,9 +167,9 @@ class (Monad m) => MonadTreeStateStore m where -- newly-certified block. writeCertifiedBlockWithFinalization :: -- | List of blocks that are newly finalized, in increasing order of height. - [StoredBlock (MPV m)] -> + [StoredBlock (MBSStore m) (MPV m)] -> -- | The newly-certified block. - StoredBlock (MPV m) -> + StoredBlock (MBSStore m) (MPV m) -> -- | A finalization entry that finalizes the last of the finalized blocks, with the successor -- quorum certificate being for the newly-certified block. FinalizationEntry (MPV m) -> @@ -180,7 +180,7 @@ class (Monad m) => MonadTreeStateStore m where -- | Look up all of the certified (non-finalized) blocks, with their quorum certificates. -- The list is in order of increasing round number. - lookupCertifiedBlocks :: m [(StoredBlock (MPV m), QuorumCertificate)] + lookupCertifiedBlocks :: m [(StoredBlock (MBSStore m) (MPV m), QuorumCertificate)] -- | Look up the status of the current round. lookupCurrentRoundStatus :: m PersistentRoundStatus diff --git a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs index 58011a51bd..b7bf78cb18 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs @@ -39,6 +39,7 @@ import Concordium.Types.HashableTo import Concordium.Types.Option import Concordium.GlobalState.LMDB.Helpers +import Concordium.GlobalState.Persistent.BlobStore (MBSStore) import Concordium.KonsensusV1.TreeState.LowLevel import Concordium.KonsensusV1.TreeState.Types import Concordium.KonsensusV1.Types @@ -66,11 +67,11 @@ instance Exception DatabaseRecoveryFailure where -- ** Block store -- | Block store for certified blocks by hash. -newtype BlockStore (pv :: ProtocolVersion) = BlockStore MDB_dbi' +newtype BlockStore store (pv :: ProtocolVersion) = BlockStore MDB_dbi' -instance (IsProtocolVersion pv) => MDBDatabase (BlockStore pv) where - type DBKey (BlockStore pv) = BlockHash - type DBValue (BlockStore pv) = StoredBlock pv +instance (IsProtocolVersion pv) => MDBDatabase (BlockStore store pv) where + type DBKey (BlockStore store pv) = BlockHash + type DBValue (BlockStore store pv) = StoredBlock store pv encodeKey _ = Hash.hashToByteString . blockHash -- ** Finalized blocks by height index @@ -198,11 +199,11 @@ instance S.Serialize VersionMetadata where -- * Database -- | The LMDB environment and tables. -data DatabaseHandlers (pv :: ProtocolVersion) = DatabaseHandlers +data DatabaseHandlers store (pv :: ProtocolVersion) = DatabaseHandlers { -- | The LMDB environment. _storeEnv :: !StoreEnv, -- | Blocks by hash. - _blockStore :: !(BlockStore pv), + _blockStore :: !(BlockStore store pv), -- | Index of finalized blocks by block height. _finalizedBlockIndex :: !FinalizedBlockIndex, -- | Index of finalized transactions by hash. @@ -259,7 +260,7 @@ makeDatabaseHandlers :: Bool -> -- | Initial database size Int -> - IO (DatabaseHandlers pv) + IO (DatabaseHandlers store pv) makeDatabaseHandlers treeStateDir readOnly initSize = do _storeEnv <- makeStoreEnv -- here nobody else has access to the environment, so we need not lock @@ -310,18 +311,18 @@ makeDatabaseHandlers treeStateDir readOnly initSize = do -- | Initialize database handlers in ReadWrite mode. -- This simply loads the references and does not initialize the databases. -openDatabase :: FilePath -> IO (DatabaseHandlers pv) +openDatabase :: FilePath -> IO (DatabaseHandlers store pv) openDatabase treeStateDir = do createDirectoryIfMissing False treeStateDir makeDatabaseHandlers treeStateDir False defaultEnvSize -- | Close the database. The database should not be used after it is closed. -closeDatabase :: DatabaseHandlers pv -> IO () +closeDatabase :: DatabaseHandlers store pv -> IO () closeDatabase dbHandlers = runInBoundThread $ mdb_env_close $ dbHandlers ^. storeEnv . seEnv -- | Check that the database version matches the expected version. -- If it does not, this throws a 'DatabaseInvariantViolation' exception. -checkDatabaseVersion :: forall pv. (IsProtocolVersion pv) => DatabaseHandlers pv -> LogIO () +checkDatabaseVersion :: forall store pv. (IsProtocolVersion pv) => DatabaseHandlers store pv -> LogIO () checkDatabaseVersion db = do metadata <- liftIO . transaction (db ^. storeEnv) True $ \txn -> loadRecord txn (db ^. metadataStore) versionMetadata @@ -349,10 +350,10 @@ checkDatabaseVersion db = do -- | 'DatabaseHandlers' existentially quantified over the protocol version and without block state. -- Note that we can treat the state type as '()' soundly when reading, since the state is the last -- part of the serialization: we just ignore the remaining bytes. -data VersionDatabaseHandlers +data VersionDatabaseHandlers store = forall pv. (IsProtocolVersion pv) => - VersionDatabaseHandlers (DatabaseHandlers pv) + VersionDatabaseHandlers (DatabaseHandlers store pv) -- | Open an existing database for reading. This checks that the version is supported and returns -- a handler that is existentially quantified over the protocol version. @@ -362,7 +363,7 @@ data VersionDatabaseHandlers openReadOnlyDatabase :: -- | Path of database FilePath -> - IO (Maybe VersionDatabaseHandlers) + IO (Maybe (VersionDatabaseHandlers store)) openReadOnlyDatabase treeStateDir = do _storeEnv <- makeStoreEnv let env = _storeEnv ^. seEnv @@ -418,25 +419,27 @@ openReadOnlyDatabase treeStateDir = do RoundStatusStore consensusStatusStore let _latestFinalizationEntryStore = LatestFinalizationEntryStore consensusStatusStore - return (Just (VersionDatabaseHandlers @pv DatabaseHandlers{..})) + return (Just (VersionDatabaseHandlers @_ @pv DatabaseHandlers{..})) _ -> Nothing <$ mdb_env_close env -- ** Monad implementation -- | A newtype wrapper that provides a 'MonadTreeStateStore' implementation using LMDB. -newtype DiskLLDBM (pv :: ProtocolVersion) m a = DiskLLDBM {runDiskLLDBM :: m a} +newtype DiskLLDBM store (pv :: ProtocolVersion) m a = DiskLLDBM {runDiskLLDBM :: m a} deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch, MonadLogger) via m deriving (MonadTrans) via IdentityT -deriving instance (MonadReader r m) => MonadReader r (DiskLLDBM pv m) +deriving instance (MonadReader r m) => MonadReader r (DiskLLDBM store pv m) -instance (IsProtocolVersion pv) => MonadProtocolVersion (DiskLLDBM pv m) where - type MPV (DiskLLDBM pv m) = pv +instance (IsProtocolVersion pv) => MonadProtocolVersion (DiskLLDBM store pv m) where + type MPV (DiskLLDBM store pv m) = pv + +type instance MBSStore (DiskLLDBM store pv m) = store -- | Helper function for implementing 'writeFinalizedBlocks'. writeFinalizedBlocksHelper :: - (HasDatabaseHandlers dbh pv, IsProtocolVersion pv) => - [StoredBlock pv] -> + (HasDatabaseHandlers dbh store pv, IsProtocolVersion pv) => + [StoredBlock store pv] -> FinalizationEntry pv -> dbh -> MDB_txn -> @@ -492,10 +495,10 @@ writeFinalizedBlocksHelper finBlocks finEntry dbh txn = do return delBlocks writeCertifiedBlockHelper :: - ( HasDatabaseHandlers s pv, + ( HasDatabaseHandlers s store pv, IsProtocolVersion pv ) => - StoredBlock pv -> + StoredBlock store pv -> QuorumCertificate -> s -> MDB_txn -> @@ -509,12 +512,12 @@ writeCertifiedBlockHelper certBlock qc dbh txn = do instance ( IsProtocolVersion pv, MonadReader r m, - HasDatabaseHandlers r pv, + HasDatabaseHandlers r store pv, MonadIO m, MonadCatch m, MonadLogger m ) => - MonadTreeStateStore (DiskLLDBM pv m) + MonadTreeStateStore (DiskLLDBM store pv m) where lookupBlock bh = do dbh <- ask @@ -623,13 +626,13 @@ instance -- | Initialise the low-level database by writing out the genesis block, initial round status and -- version metadata. initialiseLowLevelDB :: - forall pv r m. - (MonadIO m, MonadReader r m, HasDatabaseHandlers r pv, MonadLogger m, IsProtocolVersion pv) => + forall store pv r m. + (MonadIO m, MonadReader r m, HasDatabaseHandlers r store pv, MonadLogger m, IsProtocolVersion pv) => -- | Genesis block. - StoredBlock pv -> + StoredBlock store pv -> -- | Initial persistent round status. PersistentRoundStatus -> - DiskLLDBM pv m () + DiskLLDBM store pv m () initialiseLowLevelDB genesisBlock roundStatus = do dbh <- ask asWriteTransaction (dbh ^. storeEnv) $ \txn -> do @@ -644,13 +647,12 @@ initialiseLowLevelDB genesisBlock roundStatus = do storeReplaceRecord txn (dbh ^. metadataStore) versionMetadata $ S.encode metadata -- | A result of a roll back. -data RollbackResult - = forall (pv :: ProtocolVersion). - RollbackResult +data RollbackResult store (pv :: ProtocolVersion) + = RollbackResult { -- | Number of blocks rolled back. rbrCount :: !Int, -- | Reference to the best block after the rollback. - rbrBestState :: !(BlockStateRef pv) + rbrBestState :: !(BlockStateRef store pv) } -- | Remove certified and finalized blocks from the database whose states cannot be loaded. @@ -669,18 +671,18 @@ data RollbackResult -- latest finalization entry to the prior explicitly finalized block (or removing it if -- it would be for the genesis block). rollBackBlocksUntil :: - forall pv r m. + forall store pv r m. ( IsProtocolVersion pv, MonadReader r m, - HasDatabaseHandlers r pv, + HasDatabaseHandlers r store pv, MonadIO m, MonadCatch m, MonadLogger m ) => -- | Callback for checking if the state at a given reference is valid. - (BlockStateRef pv -> DiskLLDBM pv m Bool) -> + (BlockStateRef store pv -> DiskLLDBM store pv m Bool) -> -- | Returns the number of blocks rolled back and the best state after the roll back. - DiskLLDBM pv m RollbackResult + DiskLLDBM store pv m (RollbackResult store pv) rollBackBlocksUntil checkState = do lookupLastFinalizedBlock >>= \case Nothing -> throwM . DatabaseRecoveryFailure $ "No last finalized block." @@ -702,9 +704,9 @@ rollBackBlocksUntil checkState = do -- last finalized round Round -> -- highest surviving block state so far (from last finalized block) - BlockStateRef pv -> + BlockStateRef store pv -> -- returns the @RollbackResult@. - DiskLLDBM pv m RollbackResult + DiskLLDBM store pv m (RollbackResult store pv) checkCertified lastFinRound bestState = do dbh <- ask mHighestQC <- asReadTransaction (dbh ^. storeEnv) $ \txn -> @@ -722,13 +724,13 @@ rollBackBlocksUntil checkState = do -- last finalized round Round -> -- highest surviving block state so far - BlockStateRef pv -> + BlockStateRef store pv -> -- number of blocks rolled back so far Int -> -- QC for certified block to check QuorumCertificate -> -- returns the @RollbackResult@. - DiskLLDBM pv m RollbackResult + DiskLLDBM store pv m (RollbackResult store pv) checkCertifiedWithQC lastFinRound bestState !count qc = do dbh <- ask mBlock <- asReadTransaction (dbh ^. storeEnv) $ \txn -> @@ -770,13 +772,13 @@ rollBackBlocksUntil checkState = do -- last finalized round Round -> -- highest surviving block so far - BlockStateRef pv -> + BlockStateRef store pv -> -- number of blocks rolled back so far Int -> -- round to check for Round -> -- returns the @RollbackResult@. - DiskLLDBM pv m RollbackResult + DiskLLDBM store pv m (RollbackResult store pv) checkCertifiedPreviousRound lastFinRound bestState count currentRound | currentRound <= lastFinRound = return $ RollbackResult count bestState | otherwise = do @@ -821,13 +823,13 @@ rollBackBlocksUntil checkState = do -- Accumulated list of rolled-back finalized blocks in ascending height order [BlockHash] -> -- Block to roll back - StoredBlock pv -> + StoredBlock store pv -> -- Quorum certificate on the block QuorumCertificate -> -- Total number of blocks rolled back, -- List of hashes of rolled-back blocks in ascending height order, -- New last finalized block - IO (Int, [BlockHash], StoredBlock pv) + IO (Int, [BlockHash], StoredBlock store pv) loop !c hashes fin finQC = case stbBlock fin of GenesisBlock _ -> do -- As a special case, the genesis block is self-finalizing. diff --git a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/Memory.hs b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/Memory.hs index 2e4efbbdde..adb5044b18 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/Memory.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/Memory.hs @@ -19,6 +19,7 @@ import Data.Maybe (isJust) import Concordium.Types import Concordium.Types.HashableTo +import Concordium.GlobalState.Persistent.BlobStore (MBSStore) import Concordium.KonsensusV1.TreeState.LowLevel import Concordium.KonsensusV1.TreeState.Types import Concordium.KonsensusV1.Types @@ -26,11 +27,11 @@ import Concordium.KonsensusV1.Types -- | A low-level tree state database. This manages the storage and indexing of blocks and -- transactions, as well as recording persisted state of the consensus in the form of the latest -- finalization entry and current round status. -data LowLevelDB pv = LowLevelDB +data LowLevelDB store pv = LowLevelDB { -- | Index of finalized blocks by height. lldbFinalizedBlocks :: !(Map.Map BlockHeight BlockHash), -- | Table of certified blocks by hash. - lldbBlocks :: !(HM.HashMap BlockHash (StoredBlock pv)), + lldbBlocks :: !(HM.HashMap BlockHash (StoredBlock store pv)), -- | Table of finalized transactions by hash. lldbTransactions :: !(HM.HashMap TransactionHash FinalizedTransactionStatus), -- | The last finalization entry (if any). @@ -44,7 +45,7 @@ data LowLevelDB pv = LowLevelDB -- | An initial 'LowLevelDB' with the supplied genesis block and round status, but otherwise with -- no blocks, no transactions and no finalization entry. -- The genesis block should have height 0; this is not checked. -initialLowLevelDB :: StoredBlock pv -> PersistentRoundStatus -> LowLevelDB pv +initialLowLevelDB :: StoredBlock store pv -> PersistentRoundStatus -> LowLevelDB store pv initialLowLevelDB genBlock roundStatus = LowLevelDB { lldbFinalizedBlocks = Map.singleton 0 (getHash genBlock), @@ -57,7 +58,7 @@ initialLowLevelDB genBlock roundStatus = -- | Update a 'LowLevelDB' by adding the given block to 'lldbFinalizedBlocks' and all of its -- transactions to 'lldbTransactions'. Note, this does not add the block to 'lldbBlocks'. -finalizeBlock :: LowLevelDB pv -> StoredBlock pv -> LowLevelDB pv +finalizeBlock :: LowLevelDB store pv -> StoredBlock store pv -> LowLevelDB store pv finalizeBlock db@LowLevelDB{..} sb = db { lldbFinalizedBlocks = Map.insert height (getHash sb) lldbFinalizedBlocks, @@ -70,11 +71,11 @@ finalizeBlock db@LowLevelDB{..} sb = -- | Helper functions for implementing 'writeFinalizedBlocks'. doWriteFinalizedBlocks :: -- | Newly-finalized blocks in order. - [StoredBlock pv] -> + [StoredBlock store pv] -> -- | Finalization entry for the last of the finalized blocks. FinalizationEntry pv -> - LowLevelDB pv -> - LowLevelDB pv + LowLevelDB store pv -> + LowLevelDB store pv doWriteFinalizedBlocks finBlocks finEntry = flip (foldl' finalizeBlock) finBlocks . processFinEntry where @@ -96,11 +97,11 @@ doWriteFinalizedBlocks finBlocks finEntry = -- | Helper function for implementing 'writeCertifiedBlock'. doWriteCertifiedBlock :: -- | Newly-certified block. - StoredBlock pv -> + StoredBlock store pv -> -- | QC on the certified block. QuorumCertificate -> - LowLevelDB pv -> - LowLevelDB pv + LowLevelDB store pv -> + LowLevelDB store pv doWriteCertifiedBlock certBlock qc db@LowLevelDB{..} = db { lldbBlocks = @@ -112,35 +113,37 @@ doWriteCertifiedBlock certBlock qc db@LowLevelDB{..} = -- | The class 'HasMemoryLLDB' is implemented by a context in which a 'LowLevelDB' state is -- maintained in an 'IORef'. This provides access to the low-level database when the monad implements -- @MonadReader r@ and @MonadIO@. -class HasMemoryLLDB pv r | r -> pv where - theMemoryLLDB :: r -> IORef (LowLevelDB pv) +class HasMemoryLLDB store pv r | r -> store pv where + theMemoryLLDB :: r -> IORef (LowLevelDB store pv) -- | Helper for reading the low level DB. -readLLDB :: (MonadReader r m, HasMemoryLLDB pv r, MonadIO m) => m (LowLevelDB pv) +readLLDB :: (MonadReader r m, HasMemoryLLDB store pv r, MonadIO m) => m (LowLevelDB store pv) readLLDB = liftIO . readIORef =<< asks theMemoryLLDB -- | Helper for updating the low level DB. -withLLDB :: (MonadReader r m, HasMemoryLLDB pv r, MonadIO m) => (LowLevelDB pv -> (LowLevelDB pv, a)) -> m a +withLLDB :: (MonadReader r m, HasMemoryLLDB store pv r, MonadIO m) => (LowLevelDB store pv -> (LowLevelDB store pv, a)) -> m a withLLDB f = do ref <- asks theMemoryLLDB liftIO $ atomicModifyIORef' ref f -- | Helper for updating the low level DB. -withLLDB_ :: (MonadReader r m, HasMemoryLLDB pv r, MonadIO m) => (LowLevelDB pv -> LowLevelDB pv) -> m () +withLLDB_ :: (MonadReader r m, HasMemoryLLDB store pv r, MonadIO m) => (LowLevelDB store pv -> LowLevelDB store pv) -> m () withLLDB_ f = withLLDB $ (,()) . f -- | A newtype wrapper that provides an instance of 'MonadTreeStateStore' where the underlying monad -- provides a context for accessing the low-level state. That is, it implements @MonadIO@ and -- @MonadReader r@ for @r@ with @HasMemoryLLDB pv r@. -newtype MemoryLLDBM (pv :: ProtocolVersion) m a = MemoryLLDBM {runMemoryLLDBM :: m a} +newtype MemoryLLDBM store (pv :: ProtocolVersion) m a = MemoryLLDBM {runMemoryLLDBM :: m a} deriving (Functor, Applicative, Monad, MonadIO) -deriving instance (MonadReader r m) => MonadReader r (MemoryLLDBM pv m) +deriving instance (MonadReader r m) => MonadReader r (MemoryLLDBM store pv m) -instance (IsProtocolVersion pv) => MonadProtocolVersion (MemoryLLDBM pv m) where - type MPV (MemoryLLDBM pv m) = pv +instance (IsProtocolVersion pv) => MonadProtocolVersion (MemoryLLDBM store pv m) where + type MPV (MemoryLLDBM store pv m) = pv -instance (IsProtocolVersion pv, MonadReader r m, HasMemoryLLDB pv r, MonadIO m) => MonadTreeStateStore (MemoryLLDBM pv m) where +type instance MBSStore (MemoryLLDBM store pv m) = store + +instance (IsProtocolVersion pv, MonadReader r m, HasMemoryLLDB store pv r, MonadIO m) => MonadTreeStateStore (MemoryLLDBM store pv m) where lookupBlock bh = readLLDB <&> HM.lookup bh . lldbBlocks memberBlock = fmap isJust . lookupBlock diff --git a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/StartUp.hs b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/StartUp.hs index 818be4feab..9c59aef1d1 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/StartUp.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/StartUp.hs @@ -29,6 +29,7 @@ import qualified Concordium.GlobalState.AccountMap.DifferenceMap as DiffMap import Concordium.GlobalState.AccountMap.ModuleMap (ModuleDifferenceMapReference) import Concordium.GlobalState.BlockState as BlockState import Concordium.GlobalState.Parameters hiding (getChainParameters) +import Concordium.GlobalState.Persistent.BlobStore (MBSStore) import qualified Concordium.GlobalState.Persistent.BlockState as PBS import qualified Concordium.GlobalState.Statistics as Stats import qualified Concordium.GlobalState.TransactionTable as TT @@ -51,11 +52,11 @@ import qualified Data.HashMap.Strict as HM -- | Generate the 'EpochBakers' for a genesis block. genesisEpochBakers :: ( BlockStateQuery m, - GSTypes.BlockState m ~ PBS.HashedPersistentBlockState pv, + GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MBSStore m) pv, IsConsensusV1 pv, MPV m ~ pv ) => - PBS.HashedPersistentBlockState pv -> + PBS.HashedPersistentBlockState (MBSStore m) pv -> m EpochBakers genesisEpochBakers genState = do curFullBakers <- getCurrentEpochBakers genState @@ -72,14 +73,14 @@ genesisEpochBakers genState = do -- store. makeEpochBakers :: ( BlockStateQuery m, - GSTypes.BlockState m ~ PBS.HashedPersistentBlockState pv, + GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MBSStore m) pv, IsConsensusV1 pv, MPV m ~ pv, MonadThrow m, LowLevel.MonadTreeStateStore m, MonadIO m ) => - BlockPointer pv -> + BlockPointer (MBSStore m) pv -> m EpochBakers makeEpochBakers lastFinBlock = do let lfbState = bpState lastFinBlock @@ -135,14 +136,14 @@ makeEpochBakers lastFinBlock = do -- chain to find the earliest such block. findShutdownTriggerBlock :: ( LowLevel.MonadTreeStateStore m, - GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MPV m), + GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MBSStore m) (MPV m), BlockStateQuery m, IsConsensusV1 (MPV m), MonadIO m, MonadThrow m ) => - BlockPointer (MPV m) -> - m (BlockPointer (MPV m)) + BlockPointer (MBSStore m) (MPV m) -> + m (BlockPointer (MBSStore m) (MPV m)) findShutdownTriggerBlock candidateTriggerBlock = do parentHash <- case blockBakedData candidateTriggerBlock of Absent -> @@ -173,7 +174,7 @@ loadSkovData :: LowLevel.MonadTreeStateStore m, MonadIO m, BlockStateQuery m, - GSTypes.BlockState m ~ PBS.HashedPersistentBlockState pv, + GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MBSStore m) pv, MPV m ~ pv, IsConsensusV1 pv ) => @@ -185,7 +186,7 @@ loadSkovData :: Bool -> -- | The 'SkovData' and, if the consensus is shutdown, the effective protocol update and -- relative block height of the terminal block. - m (SkovData pv, Maybe (ProtocolUpdate, BlockHeight)) + m (SkovData (MBSStore m) pv, Maybe (ProtocolUpdate, BlockHeight)) loadSkovData _genesisBlockHeight _runtimeParameters didRollback = do _persistentRoundStatus <- LowLevel.lookupCurrentRoundStatus mLatestFinEntry <- LowLevel.lookupLatestFinalizationEntry @@ -325,8 +326,8 @@ loadCertifiedBlocks :: LowLevel.MonadTreeStateStore m, MonadIO m, BlockStateStorage m, - GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MPV m), - MonadState (SkovData (MPV m)) m, + GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MBSStore m) (MPV m), + MonadState (SkovData (MBSStore m) (MPV m)) m, TimeMonad m, MonadLogger m ) => @@ -442,7 +443,7 @@ loadCertifiedBlocks = do WithMetadata{wmdData = CredentialDeployment{biCred = AccountCreation{..}}} -> (Just . addressFromRegId . credId) credential _ -> Nothing loadCertBlock :: - (LowLevel.StoredBlock (MPV m), QuorumCertificate) -> + (LowLevel.StoredBlock (MBSStore m) (MPV m), QuorumCertificate) -> HM.HashMap BlockHash MapInfo -> m (HM.HashMap BlockHash MapInfo) loadCertBlock (storedBlock, qc) loadedBlocks = do diff --git a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/Types.hs b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/Types.hs index b417b98fc2..745a0ea6ad 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/Types.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/Types.hs @@ -140,26 +140,26 @@ instance HasBlockMetadata (BlockMetadata pv) where -- | A pointer to a block that has been executed -- and the resulting 'PBS.HashedPersistentBlockState'. -data BlockPointer (pv :: ProtocolVersion) = BlockPointer +data BlockPointer store (pv :: ProtocolVersion) = BlockPointer { -- | Metadata for the block. bpInfo :: !(BlockMetadata pv), -- | The signed block. bpBlock :: !(Block pv), -- | The resulting state of executing the block. - bpState :: !(PBS.HashedPersistentBlockState pv) + bpState :: !(PBS.HashedPersistentBlockState store pv) } -type instance BlockProtocolVersion (BlockPointer pv) = pv +type instance BlockProtocolVersion (BlockPointer store pv) = pv -instance HashableTo BlockHash (BlockPointer pv) where +instance HashableTo BlockHash (BlockPointer store pv) where getHash BlockPointer{..} = getHash bpBlock -- | Block pointer equality is defined on the block hash. -instance Eq (BlockPointer pv) where +instance Eq (BlockPointer store pv) where (==) = on (==) (getHash @BlockHash) -instance BlockData (BlockPointer pv) where - type BakedBlockDataType (BlockPointer pv) = SignedBlock pv +instance BlockData (BlockPointer store pv) where + type BakedBlockDataType (BlockPointer store pv) = SignedBlock pv blockRound = blockRound . bpBlock blockEpoch = blockEpoch . bpBlock blockTimestamp = blockTimestamp . bpBlock @@ -168,7 +168,7 @@ instance BlockData (BlockPointer pv) where blockTransaction i = blockTransaction i . bpBlock blockTransactionCount = blockTransactionCount . bpBlock -instance Show (BlockPointer pv) where +instance Show (BlockPointer store pv) where show BlockPointer{..} = "BlockPointer {bpInfo = " ++ show bpInfo @@ -178,7 +178,7 @@ instance Show (BlockPointer pv) where ++ show (PBS.hpbsHash bpState) ++ "] }" -instance HasBlockMetadata (BlockPointer pv) where +instance HasBlockMetadata (BlockPointer store pv) where blockMetadata = bpInfo -- | A block that is pending its parent. @@ -238,11 +238,11 @@ data TransactionStatus -- Note as we use a COMPLETE pragma below for aggregating the 'BlockAlive' and 'BlockFinalized' -- in a pattern match, then if 'BlockStatus pv' is to be modified the complete pragma MUST also be -- checked whether it is still sufficient. -data BlockStatus pv +data BlockStatus store pv = -- | The block is alive. - BlockAlive !(BlockPointer pv) + BlockAlive !(BlockPointer store pv) | -- | The block is finalized. - BlockFinalized !(BlockPointer pv) + BlockFinalized !(BlockPointer store pv) | -- | The block has been marked dead. BlockDead | -- | The block is unknown @@ -254,23 +254,23 @@ data BlockStatus pv -- Note as we use a COMPLETE pragma for the 'BlockStatus pv' variants (see below) -- then it MUST be considered if this function has to change if the type ('BlockStatus pv') -- is to be modified. -blockStatusBlock :: BlockStatus pv -> Maybe (BlockPointer pv) +blockStatusBlock :: BlockStatus store pv -> Maybe (BlockPointer store pv) blockStatusBlock (BlockAlive b) = Just b blockStatusBlock (BlockFinalized b) = Just b blockStatusBlock _ = Nothing -- | A (unidirectional) pattern for matching a block status that is either alive or finalized. -pattern BlockAliveOrFinalized :: BlockPointer pv -> BlockStatus pv +pattern BlockAliveOrFinalized :: BlockPointer store pv -> BlockStatus store pv pattern BlockAliveOrFinalized b <- (blockStatusBlock -> Just b) -- This tells GHC that these patterns are complete for 'BlockStatus'. {-# COMPLETE BlockUnknown, BlockAliveOrFinalized, BlockDead #-} -- | The status of a block as obtained without loading the block from disk. -data RecentBlockStatus pv +data RecentBlockStatus store pv = -- | The block is recent i.e. it is either 'Alive', -- 'Pending' or the last finalized block. - RecentBlock !(BlockStatus pv) + RecentBlock !(BlockStatus store pv) | -- | The block is a predecessor of the last finalized block. OldFinalized deriving (Show) @@ -343,20 +343,20 @@ prsNextSignableRound = (1 +) . prsLastSignedRound -- * @qcBlock cbQuorumCertificate == getHash cbQuorumBlock@ -- * @qcRound cbQuorumCertificate == blockRound cbQuorumBlock@ -- * @qcEpoch cbQuorumCertificate == blockEpoch cbQuorumBlock@ -data CertifiedBlock (pv :: ProtocolVersion) = CertifiedBlock +data CertifiedBlock store (pv :: ProtocolVersion) = CertifiedBlock { -- | A valid quorum certificate. cbQuorumCertificate :: !QuorumCertificate, -- | The certified block. - cbQuorumBlock :: !(BlockPointer pv) + cbQuorumBlock :: !(BlockPointer store pv) } deriving (Eq, Show) -- | The 'Round' number of a certified block. -cbRound :: CertifiedBlock pv -> Round +cbRound :: CertifiedBlock store pv -> Round cbRound = qcRound . cbQuorumCertificate -- | The 'Epoch' number of a certified block -cbEpoch :: CertifiedBlock pv -> Epoch +cbEpoch :: CertifiedBlock store pv -> Epoch cbEpoch = qcEpoch . cbQuorumCertificate -- | Details of a round timeout that can be used to produce a new block in round @@ -367,16 +367,16 @@ cbEpoch = qcEpoch . cbQuorumCertificate -- * @cbRound rtCertifiedBlock >= tcMaxRound rtTimeoutCertificate@ -- * @cbEpoch rtCertifiedBlock >= tcMaxEpoch rtTimeoutCertificate@ -- * @cbEpoch rtCertifiedBlock <= 2 + tcMinEpoch rtTimeoutCertificate@ -data RoundTimeout (pv :: ProtocolVersion) = RoundTimeout +data RoundTimeout store (pv :: ProtocolVersion) = RoundTimeout { -- | A timeout certificate. rtTimeoutCertificate :: !TimeoutCertificate, -- | Certified block for the highest known round that did not time out. - rtCertifiedBlock :: !(CertifiedBlock pv) + rtCertifiedBlock :: !(CertifiedBlock store pv) } deriving (Eq, Show) -instance ToProto (RoundTimeout pv) where - type Output (RoundTimeout pv) = Proto.RoundTimeout +instance ToProto (RoundTimeout store pv) where + type Output (RoundTimeout store pv) = Proto.RoundTimeout toProto RoundTimeout{..} = Proto.make $ do ProtoFields.timeoutCertificate .= toProto rtTimeoutCertificate ProtoFields.quorumCertificate .= toProto (cbQuorumCertificate rtCertifiedBlock) @@ -396,18 +396,18 @@ instance ToProto (RoundTimeout pv) where -- -- * If @_rsPreviousRoundTimeout = Present timeout@ then -- @_rsCurrentRound = 1 + qcRound (rtQuorumCertificate timeout)@. -data RoundStatus (pv :: ProtocolVersion) = RoundStatus +data RoundStatus store (pv :: ProtocolVersion) = RoundStatus { -- | The current 'Round'. If the previous round did not time out, this should be -- @1 + cbRound _rsHighestCertifiedBlock@. Otherwise, it should be -- @1 + tcRound timeoutCertificate@. _rsCurrentRound :: !Round, -- | The highest round for which we have sent a finalization message. - _rsHighestCertifiedBlock :: !(CertifiedBlock pv), + _rsHighestCertifiedBlock :: !(CertifiedBlock store pv), -- | The previous round timeout certificate if the previous round timed out. -- This is @Present (timeoutCertificate, quorumCertificate)@ if the previous round timed out -- and otherwise 'Absent'. In the case of @Present@ then @quorumCertificate@ is the highest -- 'QuorumCertificate' at the time that the 'TimeoutCertificate' was built. - _rsPreviousRoundTimeout :: !(Option (RoundTimeout pv)), + _rsPreviousRoundTimeout :: !(Option (RoundTimeout store pv)), -- | Flag that is 'True' if we should attempt to bake for the current round. -- This is set to 'True' when the round is advanced, and set to 'False' when we have attempted -- to bake for the round. @@ -430,8 +430,8 @@ data RoundStatus (pv :: ProtocolVersion) = RoundStatus makeLenses ''RoundStatus -instance ToProto (RoundStatus pv) where - type Output (RoundStatus pv) = Proto.RoundStatus +instance ToProto (RoundStatus store pv) where + type Output (RoundStatus store pv) = Proto.RoundStatus toProto RoundStatus{..} = Proto.make $ do ProtoFields.currentRound .= toProto _rsCurrentRound ProtoFields.highestCertifiedBlock .= toProto (cbQuorumCertificate _rsHighestCertifiedBlock) @@ -448,9 +448,9 @@ initialRoundStatus :: -- | The base timeout. Duration -> -- | The 'BlockPointer' of the genesis block. - BlockPointer pv -> + BlockPointer store pv -> -- | The initial 'RoundStatus'. - RoundStatus pv + RoundStatus store pv initialRoundStatus currentTimeout genesisBlock = RoundStatus { _rsCurrentRound = 1, diff --git a/concordium-consensus/src/Concordium/MultiVersion.hs b/concordium-consensus/src/Concordium/MultiVersion.hs index a429a4a48c..1a2505740d 100644 --- a/concordium-consensus/src/Concordium/MultiVersion.hs +++ b/concordium-consensus/src/Concordium/MultiVersion.hs @@ -11,6 +11,7 @@ {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeAbstractions #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -110,7 +111,7 @@ instance MultiVersion fc, Skov.SkovConfiguration fc UpdateHandler ) => - Skov.HandlerConfigHandlers UpdateHandler (VersionedSkovV0M fc pv) + Skov.HandlerConfigHandlers UpdateHandler (VersionedSkovV0M fc store pv) where -- Notice that isHomeBaked (in the code below) represents whether this block is baked by the -- baker ID of this node and it could be the case that the block was not baked by this node, @@ -285,7 +286,7 @@ skovV1BlockHandler :: -- | Height of the genesis block AbsoluteBlockHeight -> -- | The newly-arrived block. - SkovV1.BlockPointer pv -> + SkovV1.BlockPointer store pv -> MVR finconf () skovV1BlockHandler genHeight block = do -- Notice that isHomeBaked (in the code below) represents whether this block is baked by the @@ -318,8 +319,8 @@ skovV1FinalizeHandler :: -- | Height of the genesis block AbsoluteBlockHeight -> KonsensusV1.FinalizationEntry pv -> - [SkovV1.BlockPointer pv] -> - VersionedSkovV1M finconf pv () + [SkovV1.BlockPointer store pv] -> + VersionedSkovV1M finconf store pv () skovV1FinalizeHandler genHeight _ finalizedBlocks = do lift $ asks (notifyBlockFinalized . mvCallbacks) >>= \case @@ -347,12 +348,12 @@ data Baker = Baker } -- | Configuration for the version-0 consensus at a particular genesis index. -data VersionedConfigurationV0 finconf (pv :: ProtocolVersion) = VersionedConfigurationV0 +data VersionedConfigurationV0 finconf store (pv :: ProtocolVersion) = VersionedConfigurationV0 { -- | The 'SkovContext' (immutable) - vc0Context :: !(Skov.SkovContext (Skov.SkovConfig pv finconf UpdateHandler)), + vc0Context :: !(Skov.SkovContext store (Skov.SkovConfig pv finconf UpdateHandler)), -- | The 'SkovState' (mutable) via an 'IORef'. This should only be updated -- by a thread that holds the global lock. - vc0State :: !(IORef (Skov.SkovState (Skov.SkovConfig pv finconf UpdateHandler))), + vc0State :: !(IORef (Skov.SkovState store (Skov.SkovConfig pv finconf UpdateHandler))), -- | The genesis index vc0Index :: GenesisIndex, -- | The absolute block height of the genesis block @@ -363,12 +364,12 @@ data VersionedConfigurationV0 finconf (pv :: ProtocolVersion) = VersionedConfigu } -- | Configuration for the version-1 consensus at a particular genesis index. -data VersionedConfigurationV1 finconf (pv :: ProtocolVersion) = VersionedConfigurationV1 +data VersionedConfigurationV1 finconf store (pv :: ProtocolVersion) = VersionedConfigurationV1 { -- | The immutable 'SkovV1.SkovV1Context'. - vc1Context :: !(SkovV1.SkovV1Context pv (MVR finconf)), + vc1Context :: !(SkovV1.SkovV1Context store pv (MVR finconf)), -- | The 'SkovV1.SkovV1State' (mutable), wrapped in an 'IORef'. This should only be updated -- by a thread that holds the global lock. - vc1State :: !(IORef (SkovV1.SkovV1State pv)), + vc1State :: !(IORef (SkovV1.SkovV1State store pv)), -- | The genesis index vc1Index :: GenesisIndex, -- | The absolute block height of the genesis block @@ -382,21 +383,22 @@ data VersionedConfigurationV1 finconf (pv :: ProtocolVersion) = VersionedConfigu type VersionedConfig finconf pv = Skov.SkovConfig pv finconf UpdateHandler -- | 'SkovHandlers' instantiated for the multi-version runner. -type VersionedHandlers finconf (pv :: ProtocolVersion) = - Skov.SkovHandlers pv ThreadTimer (VersionedConfig finconf pv) (MVR finconf) +type VersionedHandlers finconf store (pv :: ProtocolVersion) = + Skov.SkovHandlers store pv ThreadTimer (VersionedConfig finconf pv) (MVR finconf) -- | The 'SkovT' monad instantiated for the multi-version runner. -- This monad is used for running operations on the version-0 consensus. -type VersionedSkovV0M finconf pv = +type VersionedSkovV0M finconf store (pv :: ProtocolVersion) = Skov.SkovT + store pv - (VersionedHandlers finconf pv) + (VersionedHandlers finconf store pv) (VersionedConfig finconf pv) (MVR finconf) -- | The monad used for running operations on the version-1 consensus. -type VersionedSkovV1M finconf pv = - SkovV1.SkovV1T pv (MVR finconf) +type VersionedSkovV1M finconf store pv = + SkovV1.SkovV1T store pv (MVR finconf) -- | An existential wrapper around a 'VersionedConfigurationV0' or 'VersionedConfigurationV1' that -- abstracts the protocol version. For 'VersionedConfigurationV0', we require 'SkovMonad' and @@ -405,18 +407,18 @@ type VersionedSkovV1M finconf pv = -- 'IsProtocolVersion' for the protocol version. data EVersionedConfiguration finconf = -- | A configuration for consensus version 0. - forall (pv :: ProtocolVersion). - ( Skov.SkovMonad (VersionedSkovV0M finconf pv), - FinalizationMonad (VersionedSkovV0M finconf pv), - BakerMonad (VersionedSkovV0M finconf pv) + forall store (pv :: ProtocolVersion). + ( Skov.SkovMonad (VersionedSkovV0M finconf store pv), + FinalizationMonad (VersionedSkovV0M finconf store pv), + BakerMonad (VersionedSkovV0M finconf store pv) ) => - EVersionedConfigurationV0 (VersionedConfigurationV0 finconf pv) + EVersionedConfigurationV0 (VersionedConfigurationV0 finconf store pv) | -- | A configuration for consensus version 1. - forall (pv :: ProtocolVersion). + forall store (pv :: ProtocolVersion). ( IsConsensusV1 pv, IsProtocolVersion pv ) => - EVersionedConfigurationV1 (VersionedConfigurationV1 finconf pv) + EVersionedConfigurationV1 (VersionedConfigurationV1 finconf store pv) -- | Get the genesis height of an 'EVersionedConfiguration'. evcGenesisHeight :: EVersionedConfiguration finconf -> AbsoluteBlockHeight @@ -436,9 +438,9 @@ evcIndex (EVersionedConfigurationV1 vc) = vc1Index vc -- | Get the protocol version associated with an 'EVersionedConfiguration'. evcProtocolVersion :: EVersionedConfiguration finconf -> ProtocolVersion -evcProtocolVersion (EVersionedConfigurationV0 (_ :: VersionedConfigurationV0 finconf pv)) = +evcProtocolVersion (EVersionedConfigurationV0 (_ :: VersionedConfigurationV0 finconf store pv)) = demoteProtocolVersion (protocolVersion @pv) -evcProtocolVersion (EVersionedConfigurationV1 (_ :: VersionedConfigurationV1 finconf pv)) = +evcProtocolVersion (EVersionedConfigurationV1 (_ :: VersionedConfigurationV1 finconf store pv)) = demoteProtocolVersion (protocolVersion @pv) -- | Activate an 'EVersionedConfiguration'. This means caching the state and @@ -463,30 +465,30 @@ class MultiVersion finconf where -- | Convert a 'VersionedConfigurationV0' to an 'EVersionedConfiguration'. newVersionV0 :: (IsProtocolVersion pv, IsConsensusV0 pv) => - VersionedConfigurationV0 finconf pv -> + VersionedConfigurationV0 finconf store pv -> EVersionedConfiguration finconf -- | Convert a 'VersionedConfigurationV1' to an 'EVersionedConfiguration'. newVersionV1 :: (IsProtocolVersion pv, IsConsensusV1 pv) => - VersionedConfigurationV1 finconf pv -> + VersionedConfigurationV1 finconf store pv -> EVersionedConfiguration finconf -- | Supply a 'VersionedSkovV0M' action with instances of 'SkovMonad', 'FinalizationMonad' and -- 'TreeStateMonad'. liftSkov :: (IsProtocolVersion pv, IsConsensusV0 pv) => - ( ( Skov.SkovMonad (VersionedSkovV0M finconf pv), - FinalizationMonad (VersionedSkovV0M finconf pv), - TreeStateMonad (VersionedSkovV0M finconf pv) + ( ( Skov.SkovMonad (VersionedSkovV0M finconf store pv), + FinalizationMonad (VersionedSkovV0M finconf store pv), + TreeStateMonad (VersionedSkovV0M finconf store pv) ) => - VersionedSkovV0M finconf pv a + VersionedSkovV0M finconf store pv a ) -> - VersionedSkovV0M finconf pv a + VersionedSkovV0M finconf store pv a instance - ( forall pv. (IsProtocolVersion pv, IsConsensusV0 pv) => BakerMonad (VersionedSkovV0M finconf pv), - forall pv. (IsProtocolVersion pv) => TreeStateMonad (VersionedSkovV0M finconf pv) + ( forall store pv. (IsProtocolVersion pv, IsConsensusV0 pv) => BakerMonad (VersionedSkovV0M finconf store pv), + forall store pv. (IsProtocolVersion pv) => TreeStateMonad (VersionedSkovV0M finconf store pv) ) => MultiVersion finconf where @@ -706,7 +708,7 @@ newGenesis (PVGenesisData (gd :: GenesisData pv)) genesisHeight = case consensus ++ show genesisHeight oldVersions <- readIORef mvVersions let vc0Index = fromIntegral (length oldVersions) - (vc0Context, st) <- + Skov.InitialisedSkov vc0Context st <- runLoggerT ( Skov.initialiseNewSkov gd @@ -723,7 +725,8 @@ newGenesis (PVGenesisData (gd :: GenesisData pv)) genesisHeight = case consensus mvLog vc0State <- newIORef st let vc0Shutdown = Skov.shutdownSkov vc0Context =<< liftIO (readIORef vc0State) - let newEConfig :: VersionedConfigurationV0 finconf pv + let + -- newEConfig :: VersionedConfigurationV0 finconf store pv newEConfig = VersionedConfigurationV0{vc0GenesisHeight = genesisHeight, ..} writeIORef mvVersions (oldVersions `Vec.snoc` newVersionV0 newEConfig) -- Notify the network layer we have a new genesis. @@ -745,8 +748,8 @@ newGenesis (PVGenesisData (gd :: GenesisData pv)) genesisHeight = case consensus -- This is used for implementing timer handlers. -- The "unlift" is implemented by using an 'MVar' to store the configuration in, -- that will be set after initialization. - configRef <- newEmptyMVar - let unliftSkov :: forall b. VersionedSkovV1M finconf pv b -> IO b + (configRef :: MVar (VersionedConfigurationV1 finconf store pv)) <- newEmptyMVar + let unliftSkov :: forall b. VersionedSkovV1M finconf store pv b -> IO b unliftSkov a = do config <- readMVar configRef runMVR (runSkovV1Transaction config a) mvr @@ -756,7 +759,7 @@ newGenesis (PVGenesisData (gd :: GenesisData pv)) genesisHeight = case consensus { gbhiAbsoluteHeight = genesisHeight, gbhiGenesisIndex = vc1Index } - (vc1Context, st) <- + (SkovV1.NewSkov vc1Context st) <- runLoggerT ( SkovV1.initialiseNewSkovV1 gd @@ -772,7 +775,7 @@ newGenesis (PVGenesisData (gd :: GenesisData pv)) genesisHeight = case consensus mvLog vc1State <- newIORef st let vc1Shutdown = SkovV1.shutdownSkovV1 vc1Context - let newEConfig :: VersionedConfigurationV1 finconf pv + let newEConfig :: VersionedConfigurationV1 finconf store pv newEConfig = VersionedConfigurationV1{vc1GenesisHeight = genesisHeight, ..} putMVar configRef newEConfig writeIORef mvVersions (oldVersions `Vec.snoc` newVersionV1 newEConfig) @@ -790,20 +793,20 @@ newGenesis (PVGenesisData (gd :: GenesisData pv)) genesisHeight = case consensus -- effectively stop accepting blocks. -- It is assumed that the thread holds the write lock. checkForProtocolUpdateV0 :: - forall lastpv fc. + forall lastpv store fc. ( IsProtocolVersion lastpv, IsConsensusV0 lastpv, MultiVersion fc, Skov.SkovConfiguration fc UpdateHandler ) => - VersionedSkovV0M fc lastpv () + VersionedSkovV0M fc store lastpv () checkForProtocolUpdateV0 = liftSkov body where body :: - ( Skov.SkovMonad (VersionedSkovV0M fc lastpv), - TreeStateMonad (VersionedSkovV0M fc lastpv) + ( Skov.SkovMonad (VersionedSkovV0M fc store lastpv), + TreeStateMonad (VersionedSkovV0M fc store lastpv) ) => - VersionedSkovV0M fc lastpv () + VersionedSkovV0M fc store lastpv () body = check >>= \case Nothing -> return () @@ -829,7 +832,7 @@ checkForProtocolUpdateV0 = liftSkov body Skov.clearSkovOnProtocolUpdate -- migrate the final block state into the new skov instance, and establish -- all the necessary transaction table, and other, invariants. - (vc0Context, st) <- do + (Skov.InitialisedSkov (vc0Context :: Skov.SkovContext newstore (Skov.SkovConfig pv fc UpdateHandler)) st) <- do ctx <- asks Skov.srContext Skov.SkovT $ do currentState <- State.get @@ -845,7 +848,7 @@ checkForProtocolUpdateV0 = liftSkov body liftIO $ do vc0State <- liftIO $ newIORef st let vc0Shutdown = Skov.shutdownSkov vc0Context =<< liftIO (readIORef vc0State) - let newEConfig :: VersionedConfigurationV0 fc newpv + let newEConfig :: VersionedConfigurationV0 fc newstore newpv newEConfig = VersionedConfigurationV0{..} writeIORef mvVersions (existingVersions `Vec.snoc` newVersionV0 newEConfig) -- Notify the network layer we have a new genesis. @@ -864,13 +867,13 @@ checkForProtocolUpdateV0 = liftSkov body let latestEraGenesisHeight = evcGenesisHeight $ Vec.last existingVersions let vc1Index = fromIntegral (length existingVersions) vc1GenesisHeight = 1 + localToAbsoluteBlockHeight latestEraGenesisHeight pvInitFinalHeight - configRef <- liftIO newEmptyMVar + (configRef :: (MVar (VersionedConfigurationV1 fc newstore pv))) <- liftIO newEmptyMVar -- We need an "unlift" operation to run a SkovV1 transaction in an IO context. -- This is used for implementing timer handlers. -- The "unlift" is implemented by using an 'MVar' to store the configuration in, -- that will be set after initialization. let - unliftSkov :: forall b. VersionedSkovV1M fc newpv b -> IO b + unliftSkov :: forall b. VersionedSkovV1M fc newstore newpv b -> IO b unliftSkov a = do config <- readMVar configRef runMVR (runSkovV1Transaction config a) mvr @@ -890,7 +893,7 @@ checkForProtocolUpdateV0 = liftSkov body } -- Migrate the old state to the new protocol and -- get the new skov context and state. - (vc1Context, newState) <- + (SkovV1.NewSkov vc1Context newState) <- liftIO $ runLoggerT ( SkovV1.migrateSkovV1 @@ -924,7 +927,7 @@ checkForProtocolUpdateV0 = liftSkov body -- Create a reference for the new state. vc1State <- liftIO $ newIORef newState let vc1Shutdown = SkovV1.shutdownSkovV1 vc1Context - newECConfig :: VersionedConfigurationV1 fc newpv + newECConfig :: VersionedConfigurationV1 fc store newpv newECConfig = VersionedConfigurationV1{..} liftIO $ do -- Write the new configuration reference. @@ -946,10 +949,10 @@ checkForProtocolUpdateV0 = liftSkov body -- Check whether a protocol update has taken effect. If it did return -- information needed to initialize a new skov instance. check :: - ( Skov.SkovMonad (VersionedSkovV0M fc lastpv), - TreeStateMonad (VersionedSkovV0M fc lastpv) + ( Skov.SkovMonad (VersionedSkovV0M fc store lastpv), + TreeStateMonad (VersionedSkovV0M fc store lastpv) ) => - VersionedSkovV0M fc lastpv (Maybe (PVInit (VersionedSkovV0M fc lastpv))) + VersionedSkovV0M fc store lastpv (Maybe (PVInit (VersionedSkovV0M fc store lastpv))) check = Skov.getProtocolUpdateStatus >>= \case ProtocolUpdated pu -> case ProtocolUpdateV0.checkUpdate @lastpv pu of @@ -1010,14 +1013,14 @@ checkForProtocolUpdateV0 = liftSkov body -- effectively stop accepting blocks. -- It is assumed that the thread holds the write lock. checkForProtocolUpdateV1 :: - forall lastpv fc. + forall lastpv store fc. ( IsProtocolVersion lastpv, IsConsensusV1 lastpv ) => - VersionedSkovV1M fc lastpv () + VersionedSkovV1M fc store lastpv () checkForProtocolUpdateV1 = body where - body :: VersionedSkovV1M fc lastpv () + body :: VersionedSkovV1M fc store lastpv () body = do check >>= \case Nothing -> return () @@ -1039,13 +1042,13 @@ checkForProtocolUpdateV1 = body let latestEraGenesisHeight = evcGenesisHeight $ Vec.last existingVersions let vc1Index = fromIntegral (length existingVersions) vc1GenesisHeight = 1 + localToAbsoluteBlockHeight latestEraGenesisHeight pvInitFinalHeight - configRef <- liftIO newEmptyMVar + (configRef :: (MVar (VersionedConfigurationV1 fc newstore pv))) <- liftIO newEmptyMVar -- We need an "unlift" operation to run a SkovV1 transaction in an IO context. -- This is used for implementing timer handlers. -- The "unlift" is implemented by using an 'MVar' to store the configuration in, -- that will be set after initialization. let - unliftSkov :: forall b. VersionedSkovV1M fc newpv b -> IO b + unliftSkov :: forall b. VersionedSkovV1M fc newstore newpv b -> IO b unliftSkov a = do config <- readMVar configRef runMVR (runSkovV1Transaction config a) mvr @@ -1061,7 +1064,7 @@ checkForProtocolUpdateV1 = body existingPbsc <- asks SkovV1._vcPersistentBlockStateContext -- Migrate the old state to the new protocol and -- get the new skov context and state. - (vc1Context, newState) <- + (SkovV1.NewSkov vc1Context newState) <- liftIO $ runLoggerT ( SkovV1.migrateSkovV1 @@ -1095,7 +1098,7 @@ checkForProtocolUpdateV1 = body -- Create a reference for the new state. vc1State <- liftIO $ newIORef newState let vc1Shutdown = SkovV1.shutdownSkovV1 vc1Context - newECConfig :: VersionedConfigurationV1 fc newpv + newECConfig :: VersionedConfigurationV1 fc store newpv newECConfig = VersionedConfigurationV1{..} liftIO $ do -- Write the new configuration reference. @@ -1115,7 +1118,7 @@ checkForProtocolUpdateV1 = body ++ ")]" check :: - VersionedSkovV1M fc lastpv (Maybe (PVInit (VersionedSkovV1M fc lastpv))) + VersionedSkovV1M fc store lastpv (Maybe (PVInit (VersionedSkovV1M fc store lastpv))) check = do SkovV1.getProtocolUpdateState >>= \case SkovV1.ProtocolUpdateStateDone{..} -> @@ -1279,11 +1282,11 @@ startupSkov genesis = do UpdateHandler ) case r of - Just (vc0Context, st) -> do + Just (Skov.InitialisedSkov @_ @_ @_ @store vc0Context st) -> do logEvent Runner LLTrace "Loaded configuration" vc0State <- liftIO $ newIORef st let vc0Shutdown = Skov.shutdownSkov vc0Context =<< liftIO (readIORef vc0State) - let newEConfig :: VersionedConfigurationV0 finconf pv + let newEConfig :: VersionedConfigurationV0 finconf store pv newEConfig = VersionedConfigurationV0 { vc0Index = genIndex, @@ -1296,6 +1299,7 @@ startupSkov genesis = do let getCurrentGenesisAndHeight :: VersionedSkovV0M finconf + store pv (BlockHash, AbsoluteBlockHeight, Maybe SomeProtocolVersion) getCurrentGenesisAndHeight = liftSkov $ do @@ -1337,8 +1341,8 @@ startupSkov genesis = do -- This is used for implementing timer handlers. -- The "unlift" is implemented by using an 'MVar' to store the configuration in, -- that will be set after initialization. - configRef <- liftIO newEmptyMVar - let unliftSkov :: forall b. VersionedSkovV1M finconf pv b -> IO b + (configRef :: MVar (VersionedConfigurationV1 finconf store pv)) <- liftIO newEmptyMVar + let unliftSkov :: forall b. VersionedSkovV1M finconf store pv b -> IO b unliftSkov a = do config <- readMVar configRef runMVR (runSkovV1Transaction config a) mvr @@ -1358,7 +1362,7 @@ startupSkov genesis = do logEvent Runner LLTrace "Loaded configuration" vc1State <- liftIO $ newIORef esState let vc1Shutdown = SkovV1.shutdownSkovV1 esContext - let newEConfig :: VersionedConfigurationV1 finconf pv + let newEConfig :: VersionedConfigurationV1 finconf store pv newEConfig = VersionedConfigurationV1 { vc1Index = genIndex, @@ -1549,8 +1553,8 @@ shutdownMultiVersionRunner MultiVersionRunner{..} = mask_ $ do -- acquire the write lock: the caller must ensure that the lock -- is held. liftSkovV0Update :: - VersionedConfigurationV0 finconf pv -> - VersionedSkovV0M finconf pv a -> + VersionedConfigurationV0 finconf store pv -> + VersionedSkovV0M finconf store pv a -> MVR finconf a liftSkovV0Update vc a = MVR $ \mvr -> do oldState <- readIORef (vc0State vc) @@ -1563,8 +1567,8 @@ liftSkovV0Update vc a = MVR $ \mvr -> do -- ensure that the lock is held. liftSkovV1Update :: (IsProtocolVersion pv, IsConsensusV1 pv) => - VersionedConfigurationV1 finconf pv -> - VersionedSkovV1M finconf pv a -> + VersionedConfigurationV1 finconf store pv -> + VersionedSkovV1M finconf store pv a -> MVR finconf a liftSkovV1Update vc a = MVR $ \mvr -> do oldState <- readIORef (vc1State vc) @@ -1597,8 +1601,8 @@ liftSkovV1Update vc a = MVR $ \mvr -> do -- If the action throws an exception, the state will not be updated, -- but the lock is guaranteed to be released. runSkovV0Transaction :: - VersionedConfigurationV0 finconf pv -> - VersionedSkovV0M finconf pv a -> + VersionedConfigurationV0 finconf store pv -> + VersionedSkovV0M finconf store pv a -> MVR finconf a runSkovV0Transaction vc a = withWriteLock $ liftSkovV0Update vc a @@ -1608,17 +1612,17 @@ runSkovV0Transaction vc a = withWriteLock $ liftSkovV0Update vc a -- but the lock is guaranteed to be released. runSkovV1Transaction :: (IsProtocolVersion pv, IsConsensusV1 pv) => - VersionedConfigurationV1 finconf pv -> - VersionedSkovV1M finconf pv a -> + VersionedConfigurationV1 finconf store pv -> + VersionedSkovV1M finconf store pv a -> MVR finconf a runSkovV1Transaction vc a = withWriteLock $ liftSkovV1Update vc a -- | An instance of 'SkovHandlers' for running operations on a -- 'VersionedConfigurationV0' within a 'MultiVersionRunner'. mvrSkovHandlers :: - VersionedConfigurationV0 finconf pv -> + VersionedConfigurationV0 finconf store pv -> MultiVersionRunner finconf -> - Skov.SkovHandlers pv ThreadTimer (Skov.SkovConfig pv finconf UpdateHandler) (MVR finconf) + Skov.SkovHandlers store pv ThreadTimer (Skov.SkovConfig pv finconf UpdateHandler) (MVR finconf) mvrSkovHandlers vc mvr@MultiVersionRunner{mvCallbacks = Callbacks{..}} = Skov.SkovHandlers { shBroadcastFinalizationMessage = @@ -1688,11 +1692,11 @@ sendCatchUpStatus :: MVR finconf () sendCatchUpStatus = MVR $ \mvr@MultiVersionRunner{..} -> do vvec <- readIORef mvVersions case Vec.last vvec of - EVersionedConfigurationV0 (vc :: VersionedConfigurationV0 finconf pv) -> do + EVersionedConfigurationV0 (vc :: VersionedConfigurationV0 finconf store pv) -> do st <- readIORef (vc0State vc) cus <- runMVR - ( Skov.evalSkovT @_ @pv + ( Skov.evalSkovT @_ @store @pv (Skov.getCatchUpStatus False) (mvrSkovHandlers vc mvr) (vc0Context vc) @@ -1702,7 +1706,7 @@ sendCatchUpStatus = MVR $ \mvr@MultiVersionRunner{..} -> do notifyCatchUpStatus mvCallbacks (vc0Index vc) $ encode $ VersionedCatchUpStatusV0 cus - EVersionedConfigurationV1 (vc :: VersionedConfigurationV1 finconf pv) -> do + EVersionedConfigurationV1 (vc :: VersionedConfigurationV1 finconf store pv) -> do st <- readIORef (vc1State vc) let cus = KonsensusV1.makeCatchUpStatusMessage $ SkovV1._v1sSkovData st notifyCatchUpStatus mvCallbacks (vc1Index vc) $ @@ -1772,7 +1776,7 @@ receiveBlock :: MVR finconf (Skov.UpdateResult, Maybe ExecuteBlock) receiveBlock gi blockBS = handleMVRExceptionsWith (Skov.ResultConsensusFailure, Nothing) $ withLatestExpectedVersion gi $ \case - (EVersionedConfigurationV0 (vc :: VersionedConfigurationV0 finconf pv)) -> do + (EVersionedConfigurationV0 (vc :: VersionedConfigurationV0 finconf store pv)) -> do MVR $ \mvr -> do now <- currentTime case deserializeExactVersionedPendingBlock (protocolVersion @pv) blockBS now of @@ -1792,7 +1796,7 @@ receiveBlock gi blockBS = handleMVRExceptionsWith (Skov.ResultConsensusFailure, Skov.executeBlock verifiedPendingBlock let cont = ExecuteBlock $ runMVR exec mvr return (updateResult, Just cont) - (EVersionedConfigurationV1 (vc :: VersionedConfigurationV1 finconf pv)) -> do + (EVersionedConfigurationV1 (vc :: VersionedConfigurationV1 finconf store pv)) -> do MVR $ \mvr -> do now <- currentTime case SkovV1.deserializeExactVersionedPendingBlock @pv blockBS now of @@ -1831,13 +1835,13 @@ executeBlock = handleMVRExceptions . liftIO . runBlock -- | Deserialize and receive a finalization message at a given genesis index. receiveFinalizationMessage :: GenesisIndex -> ByteString -> MVR finconf Skov.UpdateResult receiveFinalizationMessage gi finMsgBS = handleMVRExceptions $ withLatestExpectedVersion_ gi $ \case - (EVersionedConfigurationV0 (vc :: VersionedConfigurationV0 finconf pv)) -> + (EVersionedConfigurationV0 (vc :: VersionedConfigurationV0 finconf store pv)) -> case runGet getExactVersionedFPM finMsgBS of Left err -> do logEvent Runner LLDebug $ "Could not deserialize finalization message: " ++ err return Skov.ResultSerializationFail Right finMsg -> runSkovV0Transaction vc (finalizationReceiveMessage finMsg) - (EVersionedConfigurationV1 (vc :: VersionedConfigurationV1 finconf pv)) -> + (EVersionedConfigurationV1 (vc :: VersionedConfigurationV1 finconf store pv)) -> case decode finMsgBS of Left err -> do logEvent Runner LLDebug $ "Could not deserialize finalization message: " ++ err @@ -1859,13 +1863,13 @@ receiveFinalizationMessage gi finMsgBS = handleMVRExceptions $ withLatestExpecte -- For consensus version 1 this should be a 'FinalizationEntry'. receiveFinalization :: GenesisIndex -> ByteString -> MVR finconf Skov.UpdateResult receiveFinalization gi finBS = handleMVRExceptions $ withLatestExpectedVersion_ gi $ \case - (EVersionedConfigurationV0 (vc :: VersionedConfigurationV0 finconf pv)) -> + (EVersionedConfigurationV0 (vc :: VersionedConfigurationV0 finconf store pv)) -> case runGet getExactVersionedFinalizationRecord finBS of Left err -> do logEvent Runner LLDebug $ "Could not deserialize finalization record: " ++ err return Skov.ResultSerializationFail Right finRec -> runSkovV0Transaction vc (finalizationReceiveRecord False finRec) - (EVersionedConfigurationV1 (vc :: VersionedConfigurationV1 finconf pv)) -> do + (EVersionedConfigurationV1 (vc :: VersionedConfigurationV1 finconf store pv)) -> do case runGet get finBS of Left err -> do logEvent Runner LLDebug $ "Could not deserialize finalization entry: " <> err @@ -1904,7 +1908,7 @@ receiveCatchUpStatus gi catchUpBS cuConfig@CatchUpConfiguration{..} = vvec <- liftIO . readIORef =<< asks mvVersions case vvec Vec.!? fromIntegral gi of -- If we have a (re)genesis as the given index then... - Just (EVersionedConfigurationV0 (vc :: VersionedConfigurationV0 finconf pv)) -> + Just (EVersionedConfigurationV0 (vc :: VersionedConfigurationV0 finconf store pv)) -> case vcatchUp of VersionedCatchUpStatusNoGenesis -> return Skov.ResultSuccess VersionedCatchUpStatusV0 catchUp -> MVR $ \mvr -> do @@ -1914,8 +1918,8 @@ receiveCatchUpStatus gi catchUpBS cuConfig@CatchUpConfiguration{..} = -- acquire the write lock, or to store the resulting state. (mmsgs, res) <- runMVR - ( Skov.evalSkovT @_ @pv - ( Skov.handleCatchUpStatus @(VersionedSkovV0M finconf pv) + ( Skov.evalSkovT @_ @store @pv + ( Skov.handleCatchUpStatus @(VersionedSkovV0M finconf _ pv) catchUp catchUpMessageLimit ) @@ -1966,10 +1970,10 @@ receiveCatchUpStatus gi catchUpBS cuConfig@CatchUpConfiguration{..} = return Skov.ResultPendingBlock handleCatchUpStatusV1 :: - forall finconf pv. + forall finconf store pv. (IsProtocolVersion pv, IsConsensusV1 pv) => CatchUpConfiguration -> - VersionedConfigurationV1 finconf pv -> + VersionedConfigurationV1 finconf store pv -> KonsensusV1.CatchUpMessage -> MVR finconf Skov.UpdateResult handleCatchUpStatusV1 CatchUpConfiguration{..} vc msg = do @@ -2034,7 +2038,7 @@ handleCatchUpStatusV1 CatchUpConfiguration{..} vc msg = do st <- liftIO $ readIORef $ vc1State vc checkShouldCatchUp cumStatus st True runLowLevel :: - LowLevelDB.DiskLLDBM pv (ReaderT (SkovV1.SkovV1Context pv (MVR finconf)) (MVR finconf)) a -> + LowLevelDB.DiskLLDBM store pv (ReaderT (SkovV1.SkovV1Context store pv (MVR finconf)) (MVR finconf)) a -> MVR finconf a runLowLevel a = runReaderT (LowLevelDB.runDiskLLDBM a) (vc1Context vc) checkShouldCatchUp status st isResponse = do @@ -2053,9 +2057,14 @@ getCatchUpRequest = do mvr <- ask vvec <- liftIO $ readIORef $ mvVersions mvr case Vec.last vvec of - (EVersionedConfigurationV0 (vc :: VersionedConfigurationV0 finconf pv)) -> do + (EVersionedConfigurationV0 (vc :: VersionedConfigurationV0 finconf store pv)) -> do st <- liftIO $ readIORef $ vc0State vc - cus <- Skov.evalSkovT (Skov.getCatchUpStatus @(VersionedSkovV0M _ pv) True) (mvrSkovHandlers vc mvr) (vc0Context vc) st + cus <- + Skov.evalSkovT + (Skov.getCatchUpStatus @(VersionedSkovV0M _ store pv) True) + (mvrSkovHandlers vc mvr) + (vc0Context vc) + st return (vc0Index vc, encodeLazy $ VersionedCatchUpStatusV0 cus) (EVersionedConfigurationV1 vc) -> do st <- liftIO $ readIORef $ vc1State vc @@ -2094,11 +2103,11 @@ receiveTransaction transactionBS = handleMVRExceptionsWith (Nothing, Skov.Result mvr <- ask vvec <- liftIO $ readIORef $ mvVersions mvr case Vec.last vvec of - (EVersionedConfigurationV0 (vc :: VersionedConfigurationV0 finconf pv)) -> + (EVersionedConfigurationV0 (vc :: VersionedConfigurationV0 finconf store pv)) -> withDeserializedTransaction (protocolVersion @pv) now $ \transaction -> do st <- liftIO $ readIORef $ vc0State vc (known, verRes) <- - Skov.evalSkovT @_ @pv + Skov.evalSkovT @_ @store @pv (Skov.preverifyTransaction transaction) (mvrSkovHandlers vc mvr) (vc0Context vc) @@ -2121,7 +2130,7 @@ receiveTransaction transactionBS = handleMVRExceptionsWith (Nothing, Skov.Result -- which re-does the verification. receiveUnverified (Vec.last vvec') transaction _ -> return $! Skov.transactionVerificationResultToUpdateResult verRes - (EVersionedConfigurationV1 (vc :: VersionedConfigurationV1 finconf pv)) -> + (EVersionedConfigurationV1 (vc :: VersionedConfigurationV1 finconf store pv)) -> withDeserializedTransaction (protocolVersion @pv) now $ \transaction -> do st <- liftIO $ readIORef $ vc1State vc (known, verRes) <- @@ -2165,14 +2174,14 @@ receiveTransaction transactionBS = handleMVRExceptionsWith (Nothing, Skov.Result -- Used for importing blocks i.e. out of band catchup. receiveExecuteBlock :: GenesisIndex -> ByteString -> MVR finconf Skov.UpdateResult receiveExecuteBlock gi blockBS = withLatestExpectedVersion_ gi $ \case - EVersionedConfigurationV0 (vc :: VersionedConfigurationV0 finconf pv) -> do + EVersionedConfigurationV0 (vc :: VersionedConfigurationV0 finconf store pv) -> do now <- currentTime case deserializeExactVersionedPendingBlock (protocolVersion @pv) blockBS now of Left err -> do logEvent Runner LLDebug err return Skov.ResultSerializationFail Right block -> runSkovV0Transaction vc (Skov.receiveExecuteBlock block) - EVersionedConfigurationV1 (vc :: VersionedConfigurationV1 finconf pv) -> do + EVersionedConfigurationV1 (vc :: VersionedConfigurationV1 finconf store pv) -> do now <- currentTime case SkovV1.deserializeExactVersionedPendingBlock @pv blockBS now of Left err -> do diff --git a/concordium-consensus/src/Concordium/ProtocolUpdate/P10.hs b/concordium-consensus/src/Concordium/ProtocolUpdate/P10.hs index cd3f70ef68..3815afb9cc 100644 --- a/concordium-consensus/src/Concordium/ProtocolUpdate/P10.hs +++ b/concordium-consensus/src/Concordium/ProtocolUpdate/P10.hs @@ -17,6 +17,7 @@ import Concordium.Types import Concordium.Types.Updates import Concordium.GlobalState.BlockState +import Concordium.GlobalState.Persistent.BlobStore (MBSStore) import qualified Concordium.GlobalState.Persistent.BlockState as PBS import Concordium.GlobalState.Types import qualified Concordium.GlobalState.Types as GSTypes @@ -44,13 +45,13 @@ checkUpdate ProtocolUpdate{..} = case HM.lookup puSpecificationHash updates of updateRegenesis :: ( MPV m ~ 'P10, BlockStateStorage m, - MonadState (SkovData (MPV m)) m, - GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MPV m) + MonadState (SkovData (MBSStore m) (MPV m)) m, + GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MBSStore m) (MPV m) ) => -- | The update taking effect. Update -> -- | The terminal block of the old chain. - BlockPointer (MPV m) -> + BlockPointer (MBSStore m) (MPV m) -> m (PVInit m) updateRegenesis Reboot = Reboot.updateRegenesis diff --git a/concordium-consensus/src/Concordium/ProtocolUpdate/P10/Reboot.hs b/concordium-consensus/src/Concordium/ProtocolUpdate/P10/Reboot.hs index 63a0140d3b..97a76c1f46 100644 --- a/concordium-consensus/src/Concordium/ProtocolUpdate/P10/Reboot.hs +++ b/concordium-consensus/src/Concordium/ProtocolUpdate/P10/Reboot.hs @@ -62,6 +62,7 @@ import qualified Concordium.Genesis.Data as GenesisData import qualified Concordium.Genesis.Data.BaseV1 as BaseV1 import qualified Concordium.Genesis.Data.P10 as P10 import Concordium.GlobalState.BlockState +import Concordium.GlobalState.Persistent.BlobStore (MBSStore) import qualified Concordium.GlobalState.Persistent.BlockState as PBS import Concordium.GlobalState.Types import qualified Concordium.GlobalState.Types as GSTypes @@ -82,11 +83,11 @@ updateHash = SHA256.hash "P10.Reboot" updateRegenesis :: ( MPV m ~ 'P10, BlockStateStorage m, - MonadState (SkovData (MPV m)) m, - GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MPV m) + MonadState (SkovData (MBSStore m) (MPV m)) m, + GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MBSStore m) (MPV m) ) => -- | The terminal block of the old chain. - BlockPointer 'P10 -> + BlockPointer (MBSStore m) 'P10 -> m (PVInit m) updateRegenesis terminal = do -- Genesis time is the timestamp of the terminal block diff --git a/concordium-consensus/src/Concordium/ProtocolUpdate/P6.hs b/concordium-consensus/src/Concordium/ProtocolUpdate/P6.hs index 86f0c9756e..e1968ea66e 100644 --- a/concordium-consensus/src/Concordium/ProtocolUpdate/P6.hs +++ b/concordium-consensus/src/Concordium/ProtocolUpdate/P6.hs @@ -17,6 +17,7 @@ import Concordium.Types import Concordium.Types.Updates import Concordium.GlobalState.BlockState +import Concordium.GlobalState.Persistent.BlobStore (MBSStore) import qualified Concordium.GlobalState.Persistent.BlockState as PBS import Concordium.GlobalState.Types import qualified Concordium.GlobalState.Types as GSTypes @@ -51,13 +52,13 @@ checkUpdate ProtocolUpdate{..} = case HM.lookup puSpecificationHash updates of updateRegenesis :: ( MPV m ~ 'P6, BlockStateStorage m, - MonadState (SkovData (MPV m)) m, - GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MPV m) + MonadState (SkovData (MBSStore m) (MPV m)) m, + GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MBSStore m) (MPV m) ) => -- | The update taking effect. Update -> -- | The terminal block of the old chain. - BlockPointer (MPV m) -> + BlockPointer (MBSStore m) (MPV m) -> m (PVInit m) updateRegenesis Reboot = Reboot.updateRegenesis updateRegenesis ProtocolP7 = ProtocolP7.updateRegenesis diff --git a/concordium-consensus/src/Concordium/ProtocolUpdate/P6/ProtocolP7.hs b/concordium-consensus/src/Concordium/ProtocolUpdate/P6/ProtocolP7.hs index ff679c7855..cd6d6998a4 100644 --- a/concordium-consensus/src/Concordium/ProtocolUpdate/P6/ProtocolP7.hs +++ b/concordium-consensus/src/Concordium/ProtocolUpdate/P6/ProtocolP7.hs @@ -63,6 +63,7 @@ import qualified Concordium.Genesis.Data as GenesisData import qualified Concordium.Genesis.Data.BaseV1 as BaseV1 import qualified Concordium.Genesis.Data.P7 as P7 import Concordium.GlobalState.BlockState +import Concordium.GlobalState.Persistent.BlobStore import qualified Concordium.GlobalState.Persistent.BlockState as PBS import Concordium.GlobalState.Types import qualified Concordium.GlobalState.Types as GSTypes @@ -83,11 +84,11 @@ updateHash = read "e68ea0b16bbadfa5e5da768ed9afe0880bd572e29337fe6fb584f293ed769 updateRegenesis :: ( MPV m ~ 'P6, BlockStateStorage m, - MonadState (TreeState.SkovData (MPV m)) m, - GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MPV m) + MonadState (TreeState.SkovData (MBSStore m) (MPV m)) m, + GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MBSStore m) (MPV m) ) => -- | The terminal block of the old chain. - BlockPointer 'P6 -> + BlockPointer (MBSStore m) 'P6 -> m (PVInit m) updateRegenesis terminalBlock = do -- Genesis time is the timestamp of the terminal block diff --git a/concordium-consensus/src/Concordium/ProtocolUpdate/P6/Reboot.hs b/concordium-consensus/src/Concordium/ProtocolUpdate/P6/Reboot.hs index ec7e4c0f49..4ab86b8d15 100644 --- a/concordium-consensus/src/Concordium/ProtocolUpdate/P6/Reboot.hs +++ b/concordium-consensus/src/Concordium/ProtocolUpdate/P6/Reboot.hs @@ -62,6 +62,7 @@ import qualified Concordium.Genesis.Data as GenesisData import qualified Concordium.Genesis.Data.BaseV1 as BaseV1 import qualified Concordium.Genesis.Data.P6 as P6 import Concordium.GlobalState.BlockState +import Concordium.GlobalState.Persistent.BlobStore (MBSStore) import qualified Concordium.GlobalState.Persistent.BlockState as PBS import Concordium.GlobalState.Types import qualified Concordium.GlobalState.Types as GSTypes @@ -82,11 +83,11 @@ updateHash = SHA256.hash "P6.Reboot" updateRegenesis :: ( MPV m ~ 'P6, BlockStateStorage m, - MonadState (SkovData (MPV m)) m, - GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MPV m) + MonadState (SkovData (MBSStore m) (MPV m)) m, + GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MBSStore m) (MPV m) ) => -- | The terminal block of the old chain. - BlockPointer 'P6 -> + BlockPointer (MBSStore m) 'P6 -> m (PVInit m) updateRegenesis terminal = do -- Genesis time is the timestamp of the terminal block diff --git a/concordium-consensus/src/Concordium/ProtocolUpdate/P7.hs b/concordium-consensus/src/Concordium/ProtocolUpdate/P7.hs index f2bb1febd3..33cf785231 100644 --- a/concordium-consensus/src/Concordium/ProtocolUpdate/P7.hs +++ b/concordium-consensus/src/Concordium/ProtocolUpdate/P7.hs @@ -18,6 +18,7 @@ import Concordium.Types.Updates import qualified Concordium.Genesis.Data.P8 as P8 import Concordium.GlobalState.BlockState +import Concordium.GlobalState.Persistent.BlobStore (MBSStore) import qualified Concordium.GlobalState.Persistent.BlockState as PBS import Concordium.GlobalState.Types import qualified Concordium.GlobalState.Types as GSTypes @@ -48,13 +49,13 @@ checkUpdate ProtocolUpdate{..} = case HM.lookup puSpecificationHash updates of updateRegenesis :: ( MPV m ~ 'P7, BlockStateStorage m, - MonadState (SkovData (MPV m)) m, - GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MPV m) + MonadState (SkovData (MBSStore m) (MPV m)) m, + GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MBSStore m) (MPV m) ) => -- | The update taking effect. Update -> -- | The terminal block of the old chain. - BlockPointer (MPV m) -> + BlockPointer (MBSStore m) (MPV m) -> m (PVInit m) updateRegenesis Reboot = Reboot.updateRegenesis updateRegenesis (ProtocolP8 protocolUpdateData) = ProtocolP8.updateRegenesis protocolUpdateData diff --git a/concordium-consensus/src/Concordium/ProtocolUpdate/P7/ProtocolP8.hs b/concordium-consensus/src/Concordium/ProtocolUpdate/P7/ProtocolP8.hs index 923a9f5947..7c9907fa41 100644 --- a/concordium-consensus/src/Concordium/ProtocolUpdate/P7/ProtocolP8.hs +++ b/concordium-consensus/src/Concordium/ProtocolUpdate/P7/ProtocolP8.hs @@ -66,6 +66,7 @@ import qualified Concordium.Genesis.Data as GenesisData import qualified Concordium.Genesis.Data.BaseV1 as BaseV1 import qualified Concordium.Genesis.Data.P8 as P8 import Concordium.GlobalState.BlockState +import Concordium.GlobalState.Persistent.BlobStore (MBSStore) import qualified Concordium.GlobalState.Persistent.BlockState as PBS import Concordium.GlobalState.Types import qualified Concordium.GlobalState.Types as GSTypes @@ -86,12 +87,12 @@ updateHash = read "f12e20b6936a6b1b736e95715e1654b92adb4226ef7601b4183895bee563f updateRegenesis :: ( MPV m ~ 'P7, BlockStateStorage m, - MonadState (TreeState.SkovData (MPV m)) m, - GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MPV m) + MonadState (TreeState.SkovData (MBSStore m) (MPV m)) m, + GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MBSStore m) (MPV m) ) => P8.ProtocolUpdateData -> -- | The terminal block of the old chain. - BlockPointer 'P7 -> + BlockPointer (MBSStore m) 'P7 -> m (PVInit m) updateRegenesis protocolUpdateData terminalBlock = do -- Genesis time is the timestamp of the terminal block diff --git a/concordium-consensus/src/Concordium/ProtocolUpdate/P7/Reboot.hs b/concordium-consensus/src/Concordium/ProtocolUpdate/P7/Reboot.hs index f42cd9df66..be5d62aba4 100644 --- a/concordium-consensus/src/Concordium/ProtocolUpdate/P7/Reboot.hs +++ b/concordium-consensus/src/Concordium/ProtocolUpdate/P7/Reboot.hs @@ -62,6 +62,7 @@ import qualified Concordium.Genesis.Data as GenesisData import qualified Concordium.Genesis.Data.BaseV1 as BaseV1 import qualified Concordium.Genesis.Data.P7 as P7 import Concordium.GlobalState.BlockState +import Concordium.GlobalState.Persistent.BlobStore (MBSStore) import qualified Concordium.GlobalState.Persistent.BlockState as PBS import Concordium.GlobalState.Types import qualified Concordium.GlobalState.Types as GSTypes @@ -81,11 +82,11 @@ updateHash = SHA256.hash "P7.Reboot" updateRegenesis :: ( MPV m ~ 'P7, BlockStateStorage m, - MonadState (SkovData (MPV m)) m, - GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MPV m) + MonadState (SkovData (MBSStore m) (MPV m)) m, + GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MBSStore m) (MPV m) ) => -- | The terminal block of the old chain. - BlockPointer 'P7 -> + BlockPointer (MBSStore m) 'P7 -> m (PVInit m) updateRegenesis terminal = do -- Genesis time is the timestamp of the terminal block diff --git a/concordium-consensus/src/Concordium/ProtocolUpdate/P8.hs b/concordium-consensus/src/Concordium/ProtocolUpdate/P8.hs index 8a00fa64dd..b5cf66ae89 100644 --- a/concordium-consensus/src/Concordium/ProtocolUpdate/P8.hs +++ b/concordium-consensus/src/Concordium/ProtocolUpdate/P8.hs @@ -18,6 +18,7 @@ import Concordium.Types import Concordium.Types.Updates import Concordium.GlobalState.BlockState +import Concordium.GlobalState.Persistent.BlobStore (MBSStore) import qualified Concordium.GlobalState.Persistent.BlockState as PBS import Concordium.GlobalState.Types import qualified Concordium.GlobalState.Types as GSTypes @@ -48,13 +49,13 @@ checkUpdate ProtocolUpdate{..} = case HM.lookup puSpecificationHash updates of updateRegenesis :: ( MPV m ~ 'P8, BlockStateStorage m, - MonadState (SkovData (MPV m)) m, - GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MPV m) + MonadState (SkovData (MBSStore m) (MPV m)) m, + GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MBSStore m) (MPV m) ) => -- | The update taking effect. Update -> -- | The terminal block of the old chain. - BlockPointer (MPV m) -> + BlockPointer (MBSStore m) (MPV m) -> m (PVInit m) updateRegenesis Reboot = Reboot.updateRegenesis updateRegenesis (ProtocolP9 protocolUpdateData) = ProtocolP9.updateRegenesis protocolUpdateData diff --git a/concordium-consensus/src/Concordium/ProtocolUpdate/P8/ProtocolP9.hs b/concordium-consensus/src/Concordium/ProtocolUpdate/P8/ProtocolP9.hs index 1c326235c8..064fc44ecd 100644 --- a/concordium-consensus/src/Concordium/ProtocolUpdate/P8/ProtocolP9.hs +++ b/concordium-consensus/src/Concordium/ProtocolUpdate/P8/ProtocolP9.hs @@ -66,6 +66,7 @@ import qualified Concordium.Genesis.Data as GenesisData import qualified Concordium.Genesis.Data.BaseV1 as BaseV1 import qualified Concordium.Genesis.Data.P9 as P9 import Concordium.GlobalState.BlockState +import Concordium.GlobalState.Persistent.BlobStore (MBSStore) import qualified Concordium.GlobalState.Persistent.BlockState as PBS import Concordium.GlobalState.Types import qualified Concordium.GlobalState.Types as GSTypes @@ -86,12 +87,12 @@ updateHash = read "1524c737e9d81fe79e4fccfa0b74d11d1cd7d3217b069b4b92f0cb3490d79 updateRegenesis :: ( MPV m ~ 'P8, BlockStateStorage m, - MonadState (TreeState.SkovData (MPV m)) m, - GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MPV m) + MonadState (TreeState.SkovData (MBSStore m) (MPV m)) m, + GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MBSStore m) (MPV m) ) => P9.ProtocolUpdateData -> -- | The terminal block of the old chain. - BlockPointer 'P8 -> + BlockPointer (MBSStore m) 'P8 -> m (PVInit m) updateRegenesis protocolUpdateData terminalBlock = do -- Genesis time is the timestamp of the terminal block diff --git a/concordium-consensus/src/Concordium/ProtocolUpdate/P8/Reboot.hs b/concordium-consensus/src/Concordium/ProtocolUpdate/P8/Reboot.hs index 45d42dde76..ef3c2b3f03 100644 --- a/concordium-consensus/src/Concordium/ProtocolUpdate/P8/Reboot.hs +++ b/concordium-consensus/src/Concordium/ProtocolUpdate/P8/Reboot.hs @@ -62,6 +62,7 @@ import qualified Concordium.Genesis.Data as GenesisData import qualified Concordium.Genesis.Data.BaseV1 as BaseV1 import qualified Concordium.Genesis.Data.P8 as P8 import Concordium.GlobalState.BlockState +import Concordium.GlobalState.Persistent.BlobStore (MBSStore) import qualified Concordium.GlobalState.Persistent.BlockState as PBS import Concordium.GlobalState.Types import qualified Concordium.GlobalState.Types as GSTypes @@ -82,11 +83,11 @@ updateHash = SHA256.hash "P8.Reboot" updateRegenesis :: ( MPV m ~ 'P8, BlockStateStorage m, - MonadState (SkovData (MPV m)) m, - GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MPV m) + MonadState (SkovData (MBSStore m) (MPV m)) m, + GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MBSStore m) (MPV m) ) => -- | The terminal block of the old chain. - BlockPointer 'P8 -> + BlockPointer (MBSStore m) 'P8 -> m (PVInit m) updateRegenesis terminal = do -- Genesis time is the timestamp of the terminal block diff --git a/concordium-consensus/src/Concordium/ProtocolUpdate/P9.hs b/concordium-consensus/src/Concordium/ProtocolUpdate/P9.hs index 5f9b0af9c4..1f9266cb69 100644 --- a/concordium-consensus/src/Concordium/ProtocolUpdate/P9.hs +++ b/concordium-consensus/src/Concordium/ProtocolUpdate/P9.hs @@ -17,6 +17,7 @@ import Concordium.Types import Concordium.Types.Updates import Concordium.GlobalState.BlockState +import Concordium.GlobalState.Persistent.BlobStore (MBSStore) import qualified Concordium.GlobalState.Persistent.BlockState as PBS import Concordium.GlobalState.Types import qualified Concordium.GlobalState.Types as GSTypes @@ -47,13 +48,13 @@ checkUpdate ProtocolUpdate{..} = case HM.lookup puSpecificationHash updates of updateRegenesis :: ( MPV m ~ 'P9, BlockStateStorage m, - MonadState (SkovData (MPV m)) m, - GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MPV m) + MonadState (SkovData (MBSStore m) (MPV m)) m, + GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MBSStore m) (MPV m) ) => -- | The update taking effect. Update -> -- | The terminal block of the old chain. - BlockPointer (MPV m) -> + BlockPointer (MBSStore m) (MPV m) -> m (PVInit m) updateRegenesis Reboot = Reboot.updateRegenesis updateRegenesis ProtocolP10 = ProtocolP10.updateRegenesis diff --git a/concordium-consensus/src/Concordium/ProtocolUpdate/P9/ProtocolP10.hs b/concordium-consensus/src/Concordium/ProtocolUpdate/P9/ProtocolP10.hs index df282537a6..734e6cf776 100644 --- a/concordium-consensus/src/Concordium/ProtocolUpdate/P9/ProtocolP10.hs +++ b/concordium-consensus/src/Concordium/ProtocolUpdate/P9/ProtocolP10.hs @@ -65,6 +65,7 @@ import qualified Concordium.Genesis.Data as GenesisData import qualified Concordium.Genesis.Data.BaseV1 as BaseV1 import qualified Concordium.Genesis.Data.P10 as P10 import Concordium.GlobalState.BlockState +import Concordium.GlobalState.Persistent.BlobStore (MBSStore) import qualified Concordium.GlobalState.Persistent.BlockState as PBS import Concordium.GlobalState.Types import qualified Concordium.GlobalState.Types as GSTypes @@ -84,10 +85,10 @@ updateHash = read "6d84de01ccda394638459daa6b9e374094236d3e2e8fd19a51e7136abe77b updateRegenesis :: ( MPV m ~ 'P9, BlockStateStorage m, - MonadState (TreeState.SkovData (MPV m)) m, - GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MPV m) + MonadState (TreeState.SkovData (MBSStore m) (MPV m)) m, + GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MBSStore m) (MPV m) ) => - BlockPointer 'P9 -> + BlockPointer (MBSStore m) 'P9 -> m (PVInit m) updateRegenesis terminalBlock = do let regenesisTime = blockTimestamp terminalBlock diff --git a/concordium-consensus/src/Concordium/ProtocolUpdate/P9/Reboot.hs b/concordium-consensus/src/Concordium/ProtocolUpdate/P9/Reboot.hs index baad9187ca..d6540a5ea9 100644 --- a/concordium-consensus/src/Concordium/ProtocolUpdate/P9/Reboot.hs +++ b/concordium-consensus/src/Concordium/ProtocolUpdate/P9/Reboot.hs @@ -62,6 +62,7 @@ import qualified Concordium.Genesis.Data as GenesisData import qualified Concordium.Genesis.Data.BaseV1 as BaseV1 import qualified Concordium.Genesis.Data.P9 as P9 import Concordium.GlobalState.BlockState +import Concordium.GlobalState.Persistent.BlobStore (MBSStore) import qualified Concordium.GlobalState.Persistent.BlockState as PBS import Concordium.GlobalState.Types import qualified Concordium.GlobalState.Types as GSTypes @@ -82,11 +83,11 @@ updateHash = SHA256.hash "P9.Reboot" updateRegenesis :: ( MPV m ~ 'P9, BlockStateStorage m, - MonadState (SkovData (MPV m)) m, - GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MPV m) + MonadState (SkovData (MBSStore m) (MPV m)) m, + GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MBSStore m) (MPV m) ) => -- | The terminal block of the old chain. - BlockPointer 'P9 -> + BlockPointer (MBSStore m) 'P9 -> m (PVInit m) updateRegenesis terminal = do -- Genesis time is the timestamp of the terminal block diff --git a/concordium-consensus/src/Concordium/ProtocolUpdate/V1.hs b/concordium-consensus/src/Concordium/ProtocolUpdate/V1.hs index 5a1c070156..1aaf5ad674 100644 --- a/concordium-consensus/src/Concordium/ProtocolUpdate/V1.hs +++ b/concordium-consensus/src/Concordium/ProtocolUpdate/V1.hs @@ -12,6 +12,7 @@ import Concordium.Types import Concordium.Types.Updates import Concordium.GlobalState.BlockState (BlockStateStorage) +import Concordium.GlobalState.Persistent.BlobStore (MBSStore) import qualified Concordium.GlobalState.Persistent.BlockState as PBS import Concordium.GlobalState.Types (PVInit) import qualified Concordium.GlobalState.Types as GSTypes @@ -57,13 +58,13 @@ checkUpdate = case protocolVersion @pv of -- | Construct the genesis data for a P1 update. updateRegenesis :: ( BlockStateStorage m, - MonadState (SkovData (MPV m)) m, - GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MPV m) + MonadState (SkovData (MBSStore m) (MPV m)) m, + GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MBSStore m) (MPV m) ) => -- | The update to take effect. Update (MPV m) -> -- | The terminal block of the old chain. - BlockPointer (MPV m) -> + BlockPointer (MBSStore m) (MPV m) -> m (PVInit m) updateRegenesis (UpdateP6 u) = P6.updateRegenesis u updateRegenesis (UpdateP7 u) = P7.updateRegenesis u diff --git a/concordium-consensus/src/Concordium/Queries.hs b/concordium-consensus/src/Concordium/Queries.hs index 9a976bdd79..f933bf1c23 100644 --- a/concordium-consensus/src/Concordium/Queries.hs +++ b/concordium-consensus/src/Concordium/Queries.hs @@ -100,17 +100,17 @@ import Data.Time -- | Type of a query that can be run against consensus version 0. type QueryV0M finconf a = - forall (pv :: ProtocolVersion). - ( SkovMonad (VersionedSkovV0M finconf pv), - FinalizationMonad (VersionedSkovV0M finconf pv) + forall store (pv :: ProtocolVersion). + ( SkovMonad (VersionedSkovV0M finconf store pv), + FinalizationMonad (VersionedSkovV0M finconf store pv) ) => - VersionedSkovV0M finconf pv a + VersionedSkovV0M finconf store pv a -- | Type of a query that can be run against consensus version 1. type QueryV1M finconf a = - forall (pv :: ProtocolVersion). + forall store (pv :: ProtocolVersion). (IsConsensusV1 pv, IsProtocolVersion pv) => - VersionedSkovV1M finconf pv a + VersionedSkovV1M finconf store pv a -- | Run a query against a specific skov version. liftSkovQuery :: @@ -129,18 +129,18 @@ liftSkovQueryWithVersion :: MultiVersionRunner finconf -> EVersionedConfiguration finconf -> -- | Query to run at version 0 consensus. - ( forall (pv :: ProtocolVersion). - ( SkovMonad (VersionedSkovV0M finconf pv), - FinalizationMonad (VersionedSkovV0M finconf pv) + ( forall store (pv :: ProtocolVersion). + ( SkovMonad (VersionedSkovV0M finconf store pv), + FinalizationMonad (VersionedSkovV0M finconf store pv) ) => - VersionedConfigurationV0 finconf pv -> - VersionedSkovV0M finconf pv a + VersionedConfigurationV0 finconf store pv -> + VersionedSkovV0M finconf store pv a ) -> -- | Query to run at version 1 consensus. - ( forall (pv :: ProtocolVersion). + ( forall store (pv :: ProtocolVersion). (IsConsensusV1 pv, IsProtocolVersion pv) => - VersionedConfigurationV1 finconf pv -> - VersionedSkovV1M finconf pv a + VersionedConfigurationV1 finconf store pv -> + VersionedSkovV1M finconf store pv a ) -> IO a liftSkovQueryWithVersion mvr (EVersionedConfigurationV0 vc) av0 _ = do @@ -208,18 +208,18 @@ liftSkovQueryLatestResult av0 av1 = MVR $ \mvr -> liftSkovQueryBlock :: forall finconf a. -- | Query to run at consensus version 0. - ( forall (pv :: ProtocolVersion). - ( SkovMonad (VersionedSkovV0M finconf pv), - FinalizationMonad (VersionedSkovV0M finconf pv) + ( forall store (pv :: ProtocolVersion). + ( SkovMonad (VersionedSkovV0M finconf store pv), + FinalizationMonad (VersionedSkovV0M finconf store pv) ) => - BlockPointerType (VersionedSkovV0M finconf pv) -> - VersionedSkovV0M finconf pv a + BlockPointerType (VersionedSkovV0M finconf store pv) -> + VersionedSkovV0M finconf store pv a ) -> -- | Query to run at consensus version 1. - ( forall (pv :: ProtocolVersion). + ( forall store (pv :: ProtocolVersion). (IsConsensusV1 pv, IsProtocolVersion pv) => - SkovV1.BlockPointer pv -> - VersionedSkovV1M finconf pv a + SkovV1.BlockPointer store pv -> + VersionedSkovV1M finconf store pv a ) -> BlockHash -> MVR finconf (Maybe a) @@ -269,19 +269,19 @@ responseToMaybe response = case response of liftSkovQueryBHI :: forall finconf a. -- | Query to run at consensus version 0. - ( forall (pv :: ProtocolVersion). - ( SkovMonad (VersionedSkovV0M finconf pv), - FinalizationMonad (VersionedSkovV0M finconf pv), + ( forall store (pv :: ProtocolVersion). + ( SkovMonad (VersionedSkovV0M finconf store pv), + FinalizationMonad (VersionedSkovV0M finconf store pv), IsProtocolVersion pv ) => - BlockPointerType (VersionedSkovV0M finconf pv) -> - VersionedSkovV0M finconf pv a + BlockPointerType (VersionedSkovV0M finconf store pv) -> + VersionedSkovV0M finconf store pv a ) -> -- | Query to run at consensus version 1. - ( forall (pv :: ProtocolVersion). + ( forall store (pv :: ProtocolVersion). (IsConsensusV1 pv, IsProtocolVersion pv) => - SkovV1.BlockPointer pv -> - VersionedSkovV1M finconf pv a + SkovV1.BlockPointer store pv -> + VersionedSkovV1M finconf store pv a ) -> BlockHashInput -> MVR finconf (BHIQueryResponse a) @@ -306,7 +306,7 @@ liftSkovQueryStateBHI stateQuery = (stateQuery <=< blockState) -- A helper function for getting the best block in consensus version 1. It is the block with the highest QC. -bestBlockConsensusV1 :: (MonadState (SkovV1.SkovData pv) m) => m (SkovV1.BlockPointer pv) +bestBlockConsensusV1 :: (MonadState (SkovV1.SkovData store pv) m) => m (SkovV1.BlockPointer store pv) bestBlockConsensusV1 = SkovV1.cbQuorumBlock <$> use (SkovV1.roundStatus . SkovV1.rsHighestCertifiedBlock) -- | Try a 'BlockHashInput' based query on the latest skov version, provided with the configuration. @@ -316,24 +316,24 @@ bestBlockConsensusV1 = SkovV1.cbQuorumBlock <$> use (SkovV1.roundStatus . SkovV1 liftSkovQueryBHIAndVersion :: forall finconf a. -- | Query to run at consensus version 0. - ( forall (pv :: ProtocolVersion). - ( SkovMonad (VersionedSkovV0M finconf pv), - FinalizationMonad (VersionedSkovV0M finconf pv), + ( forall store (pv :: ProtocolVersion). + ( SkovMonad (VersionedSkovV0M finconf store pv), + FinalizationMonad (VersionedSkovV0M finconf store pv), IsProtocolVersion pv ) => - VersionedConfigurationV0 finconf pv -> - BlockPointerType (VersionedSkovV0M finconf pv) -> - VersionedSkovV0M finconf pv a + VersionedConfigurationV0 finconf store pv -> + BlockPointerType (VersionedSkovV0M finconf store pv) -> + VersionedSkovV0M finconf store pv a ) -> -- | Query to run at consensus version 1. -- As well as the versioned configuration and block pointer, this takes a 'Bool' indicating -- if the block is finalized. - ( forall (pv :: ProtocolVersion). + ( forall store (pv :: ProtocolVersion). (IsConsensusV1 pv, IsProtocolVersion pv) => - VersionedConfigurationV1 finconf pv -> - SkovV1.BlockPointer pv -> + VersionedConfigurationV1 finconf store pv -> + SkovV1.BlockPointer store pv -> Bool -> - VersionedSkovV1M finconf pv a + VersionedSkovV1M finconf store pv a ) -> BlockHashInput -> MVR finconf (BHIQueryResponse a) @@ -441,11 +441,11 @@ getConsensusStatus = MVR $ \mvr -> do (statusV1 genInfo evc) where statusV0 :: - forall (pv :: ProtocolVersion). - (SkovMonad (VersionedSkovV0M finconf pv)) => + forall store (pv :: ProtocolVersion). + (SkovMonad (VersionedSkovV0M finconf store pv)) => (BlockHash, UTCTime) -> EVersionedConfiguration finconf -> - VersionedSkovV0M finconf pv ConsensusStatus + VersionedSkovV0M finconf store pv ConsensusStatus statusV0 (csGenesisBlock, csGenesisTime) evc = do let absoluteHeight = localToAbsoluteBlockHeight (evcGenesisHeight evc) . bpHeight bb <- bestBlock @@ -484,11 +484,11 @@ getConsensusStatus = MVR $ \mvr -> do csConcordiumBFTStatus = Nothing return ConsensusStatus{..} statusV1 :: - forall (pv :: ProtocolVersion). + forall store (pv :: ProtocolVersion). (IsProtocolVersion pv, IsConsensusV1 pv) => (BlockHash, UTCTime) -> EVersionedConfiguration finconf -> - VersionedSkovV1M finconf pv ConsensusStatus + VersionedSkovV1M finconf store pv ConsensusStatus statusV1 (csGenesisBlock, csGenesisTime) evc = do let absoluteHeight = localToAbsoluteBlockHeight (evcGenesisHeight evc) . SkovV1.blockHeight bb <- bestBlockConsensusV1 @@ -717,7 +717,7 @@ getNextAccountNonce accountAddress = getBlockInfo :: BlockHashInput -> MVR finconf (BHIQueryResponse BlockInfo) getBlockInfo = liftSkovQueryBHIAndVersion - ( \(vc :: VersionedConfigurationV0 finconf pv) bp -> do + ( \(vc :: VersionedConfigurationV0 finconf store pv) bp -> do let biBlockHash = getHash bp let biGenesisIndex = vc0Index vc biBlockParent <- @@ -752,7 +752,7 @@ getBlockInfo = let biEpoch = Nothing return BlockInfo{..} ) - ( \(vc :: VersionedConfigurationV1 finconf pv) bp biFinalized -> do + ( \(vc :: VersionedConfigurationV1 finconf store pv) bp biFinalized -> do let biBlockHash = getHash bp let biGenesisIndex = vc1Index vc biBlockParent <- @@ -814,19 +814,19 @@ getBlockTransactionSummaries = getBTSv1 where getBTSv0 :: - forall (pv :: ProtocolVersion). - (SkovMonad (VersionedSkovV0M finconf pv)) => - BlockPointerType (VersionedSkovV0M finconf pv) -> - VersionedSkovV0M finconf pv (Either String (Vec.Vector SupplementedTransactionSummary)) + forall store (pv :: ProtocolVersion). + (SkovMonad (VersionedSkovV0M finconf store pv)) => + BlockPointerType (VersionedSkovV0M finconf store pv) -> + VersionedSkovV0M finconf store pv (Either String (Vec.Vector SupplementedTransactionSummary)) getBTSv0 bp = do outcomes <- BS.getOutcomes =<< blockState bp let transactions = blockTransactions bp return $! supplementOutcomes (protocolVersion @pv) outcomes transactions getBTSv1 :: - forall (pv :: ProtocolVersion). + forall store (pv :: ProtocolVersion). (IsProtocolVersion pv) => - SkovV1.BlockPointer pv -> - VersionedSkovV1M finconf pv (Either String (Vec.Vector SupplementedTransactionSummary)) + SkovV1.BlockPointer store pv -> + VersionedSkovV1M finconf store pv (Either String (Vec.Vector SupplementedTransactionSummary)) getBTSv1 bp = do outcomes <- BS.getOutcomes =<< blockState bp let transactions = SkovV1.blockTransactions bp @@ -983,10 +983,10 @@ getBlockFinalizationSummary :: forall finconf. BlockHashInput -> MVR finconf (BH getBlockFinalizationSummary = liftSkovQueryBHI getFinSummarySkovM (\_ -> return NoSummary) where getFinSummarySkovM :: - forall pv. - (SkovMonad (VersionedSkovV0M finconf pv)) => - BlockPointerType (VersionedSkovV0M finconf pv) -> - VersionedSkovV0M finconf pv BlockFinalizationSummary + forall store pv. + (SkovMonad (VersionedSkovV0M finconf store pv)) => + BlockPointerType (VersionedSkovV0M finconf store pv) -> + VersionedSkovV0M finconf store pv BlockFinalizationSummary getFinSummarySkovM bp = do case blockFinalizationData <$> blockFields bp of Just (BlockFinalizationData FinalizationRecord{..}) -> do @@ -1226,9 +1226,9 @@ getAccountInfoV0 = getAccountInfoHelper getASIv0 getCooldownsV0 -- | Get the details of an account, for the V1 consensus. getAccountInfoV1 :: - forall m. + forall m store. ( BS.BlockStateQuery m, - MonadState (SkovV1.SkovData (MPV m)) m, + MonadState (SkovV1.SkovData store (MPV m)) m, IsConsensusV1 (MPV m) ) => AccountIdentifier -> @@ -1329,12 +1329,17 @@ getInstanceInfoHelper caddr bs = do Wasm.iiSourceModule = GSWasm.miModuleRef (instanceModuleInterface iiParameters) } +data LoadablePersistentStateV1 = forall store. LoadablePersistentStateV1 + { lpsState :: StateV1.PersistentState store, + lpsLoadCallback :: StateV1.LoadCallback store + } + -- | Get the exact state of a smart contract instance in the block state. The -- return value is 'Nothing' if the instance cannot be found (either the -- requested block does not exist, or the instance does not exist in that -- block), @Just . Left@ if the instance is a V0 instance, and @Just . Right@ if -- the instance is a V1 instance. -getInstanceState :: BlockHashInput -> ContractAddress -> MVR finconf (BHIQueryResponse (Maybe (Either Wasm.ContractState (StateV1.PersistentState, StateV1.LoadCallback)))) +getInstanceState :: BlockHashInput -> ContractAddress -> MVR finconf (BHIQueryResponse (Maybe (Either Wasm.ContractState LoadablePersistentStateV1))) getInstanceState bhi caddr = do liftSkovQueryStateBHI (\bs -> mkII =<< BS.getContractInstance bs caddr) @@ -1346,7 +1351,7 @@ getInstanceState bhi caddr = do mkII (Just (BS.InstanceInfoV1 BS.InstanceInfoV{..})) = do cstate <- BS.externalContractState iiState callback <- BS.getV1StateContext - return . Just . Right $ (cstate, callback) + return . Just . Right $ LoadablePersistentStateV1 cstate callback -- | Get the source of a module as it was deployed to the chain. getModuleSource :: BlockHashInput -> ModuleRef -> MVR finconf (BHIQueryResponse (Maybe Wasm.WasmModule)) @@ -1773,13 +1778,13 @@ getBlockCertificates :: forall finconf. BlockHashInput -> MVR finconf (BHIQueryR getBlockCertificates = liftSkovQueryBHI (\_ -> return $ Left BlockCertificatesInvalidProtocolVersion) (fmap Right . getCertificates) where getCertificates :: - forall m. + forall store m. ( BS.BlockStateQuery m, BlockPointerMonad m, - BlockPointerType m ~ SkovV1.BlockPointer (MPV m), + BlockPointerType m ~ SkovV1.BlockPointer store (MPV m), IsConsensusV1 (MPV m) ) => - SkovV1.BlockPointer (MPV m) -> + SkovV1.BlockPointer store (MPV m) -> m QueriesKonsensusV1.BlockCertificates getCertificates bp = case SkovV1.bpBlock bp of @@ -1856,11 +1861,11 @@ getBakersRewardPeriod :: forall finconf. BlockHashInput -> MVR finconf (BHIQuery getBakersRewardPeriod = liftSkovQueryBHI bakerRewardPeriodInfosV0 bakerRewardPeriodInfosV1 where bakerRewardPeriodInfosV0 :: - forall m. + forall store m. ( SkovQueryMonad m, - BlockPointerType m ~ PersistentBlockPointer (MPV m) (HashedPersistentBlockState (MPV m)) + BlockPointerType m ~ PersistentBlockPointer (MPV m) (HashedPersistentBlockState store (MPV m)) ) => - BlockPointerType (VersionedSkovV0M finconf (MPV m)) -> + BlockPointerType (VersionedSkovV0M finconf store (MPV m)) -> m (Either GetBakersRewardPeriodError [BakerRewardPeriodInfo]) bakerRewardPeriodInfosV0 bp = case delegationSupport @(AccountVersionFor (MPV m)) of -- The protocol version does not support the delegation feature. @@ -1869,9 +1874,9 @@ getBakersRewardPeriod = liftSkovQueryBHI bakerRewardPeriodInfosV0 bakerRewardPer result <- getBakersConsensusV0 =<< blockState bp return $ Right result bakerRewardPeriodInfosV1 :: - forall m. - (BS.BlockStateQuery m, IsConsensusV1 (MPV m), BlockPointerMonad m, BlockPointerType m ~ SkovV1.BlockPointer (MPV m)) => - SkovV1.BlockPointer (MPV m) -> + forall store m. + (BS.BlockStateQuery m, IsConsensusV1 (MPV m), BlockPointerMonad m, BlockPointerType m ~ SkovV1.BlockPointer store (MPV m)) => + SkovV1.BlockPointer store (MPV m) -> m (Either GetBakersRewardPeriodError [BakerRewardPeriodInfo]) bakerRewardPeriodInfosV1 bp = do result <- getBakersConsensusV1 =<< blockState bp diff --git a/concordium-consensus/src/Concordium/Scheduler.hs b/concordium-consensus/src/Concordium/Scheduler.hs index 9162b9497c..4e5005e900 100644 --- a/concordium-consensus/src/Concordium/Scheduler.hs +++ b/concordium-consensus/src/Concordium/Scheduler.hs @@ -103,6 +103,7 @@ import qualified Concordium.Types.ProtocolLevelTokens.CBOR as PLTTypes import Lens.Micro.Platform import qualified Concordium.GlobalState.ContractStateV1 as StateV1 +import Concordium.GlobalState.Persistent.BlobStore (MBSStore) import Concordium.GlobalState.Persistent.BlockState.ProtocolLevelTokens (PLTConfiguration (..)) import qualified Concordium.Scheduler.ProtocolLevelTokens.Module as TokenModule import Concordium.Scheduler.WasmIntegration.V1 (ReceiveResultData (rrdCurrentState)) @@ -1225,7 +1226,7 @@ handleContractUpdateV1 depth originAddr istance checkAndGetSender transferAmount -- to appropriate handlers. let go :: [Event' supplemented] -> - Either WasmV1.ContractExecutionReject WasmV1.ReceiveResultData -> + Either WasmV1.ContractExecutionReject (WasmV1.ReceiveResultData (MBSStore m)) -> -- \^Result of invoking an operation LocalT r m (Either WasmV1.ContractCallFailure (WasmV1.ReturnValue, [Event' supplemented])) go _ (Left cer) = return (Left (WasmV1.ExecutionReject cer)) -- contract execution failed. diff --git a/concordium-consensus/src/Concordium/Scheduler/DummyData.hs b/concordium-consensus/src/Concordium/Scheduler/DummyData.hs index 9d1925c694..29d1c621a8 100644 --- a/concordium-consensus/src/Concordium/Scheduler/DummyData.hs +++ b/concordium-consensus/src/Concordium/Scheduler/DummyData.hs @@ -176,7 +176,7 @@ makeTestAccount :: Sig.VerifyKey -> AccountAddress -> Amount -> - m (BS.PersistentAccount av) + m (BS.PersistentAccount (Blob.MBSStore m) av) makeTestAccount key accountAddress amount = do let credential = makeTestCredential key accountAddress account <- BS.newAccount dummyCryptographicParameters accountAddress credential @@ -205,7 +205,7 @@ makeTestAccountFromSeed :: (IsAccountVersion av, Blob.MonadBlobStore m) => Amount -> Int -> - m (BS.PersistentAccount av) + m (BS.PersistentAccount (Blob.MBSStore m) av) makeTestAccountFromSeed amount seed = let keyPair = keyPairFromSeed seed address = accountAddressFromSeed seed diff --git a/concordium-consensus/src/Concordium/Scheduler/Environment.hs b/concordium-consensus/src/Concordium/Scheduler/Environment.hs index af518df4af..a1247c1498 100644 --- a/concordium-consensus/src/Concordium/Scheduler/Environment.hs +++ b/concordium-consensus/src/Concordium/Scheduler/Environment.hs @@ -44,6 +44,7 @@ import qualified Concordium.TransactionVerification as TVer import Control.Exception (assert) import qualified Concordium.GlobalState.ContractStateV1 as StateV1 +import Concordium.GlobalState.Persistent.BlobStore (MBSStore) import qualified Concordium.GlobalState.Persistent.BlockState.ProtocolLevelTokens as Token import qualified Concordium.ID.Types as ID import Concordium.Scheduler.ProtocolLevelTokens.Kernel (PLTAccount, PLTKernelChargeEnergy, PLTKernelFail, PLTKernelPrivilegedUpdate) @@ -130,7 +131,7 @@ class -- | Create new instance in the global state. -- The instance is parametrised by the address, and the return value is the -- address assigned to the new instance. - putNewInstance :: (IsWasmVersion v) => NewInstanceData (InstrumentedModuleRef m v) v -> m ContractAddress + putNewInstance :: (IsWasmVersion v) => NewInstanceData (MBSStore m) (InstrumentedModuleRef m v) v -> m ContractAddress -- | Bump the next available transaction nonce of the account. -- Precondition: the account exists in the block state. @@ -435,31 +436,38 @@ class -- | Contract state that is lazily thawed. This is used in the scheduler when -- looking up contracts. When looking them up first time we don't convert the -- state since this might not be needed. -data TemporaryContractState contractState (v :: Wasm.WasmVersion) +data TemporaryContractState contractState store (v :: Wasm.WasmVersion) = Frozen (contractState v) - | Thawed (UpdatableContractState v) + | Thawed (UpdatableContractState store v) {-# INLINE getRuntimeReprV0 #-} -getRuntimeReprV0 :: (ContractStateOperations m) => TemporaryContractState (ContractState m) GSWasm.V0 -> m Wasm.ContractState +getRuntimeReprV0 :: + (ContractStateOperations m) => + TemporaryContractState (ContractState m) (MBSStore m) GSWasm.V0 -> m Wasm.ContractState getRuntimeReprV0 (Frozen cs) = thawContractState cs getRuntimeReprV0 (Thawed cs) = return cs {-# INLINE getRuntimeReprV1 #-} -getRuntimeReprV1 :: (ContractStateOperations m) => TemporaryContractState (ContractState m) GSWasm.V1 -> m StateV1.MutableState +getRuntimeReprV1 :: + (ContractStateOperations m) => + TemporaryContractState (ContractState m) (MBSStore m) GSWasm.V1 -> + m (StateV1.MutableState (MBSStore m)) getRuntimeReprV1 (Frozen cs) = thawContractState cs getRuntimeReprV1 (Thawed cs) = return cs -getStateSizeV0 :: (ContractStateOperations m) => TemporaryContractState (ContractState m) GSWasm.V0 -> m Wasm.ByteSize +getStateSizeV0 :: + (ContractStateOperations m) => + TemporaryContractState (ContractState m) (MBSStore m) GSWasm.V0 -> m Wasm.ByteSize getStateSizeV0 (Frozen cs) = stateSizeV0 cs getStateSizeV0 (Thawed cs) = return $ Wasm.contractStateSize cs -- | Updatable instance information. This is used in the scheduler to efficiently -- update contract states. -type UInstanceInfo m = InstanceInfoType (InstrumentedModuleRef m) (TemporaryContractState (ContractState m)) +type UInstanceInfo m = InstanceInfoType (InstrumentedModuleRef m) (TemporaryContractState (ContractState m) (MBSStore m)) -- | Updatable instance information, versioned variant. This is used in the scheduler to efficiently -- update contract states. -type UInstanceInfoV m = InstanceInfoTypeV (InstrumentedModuleRef m) (TemporaryContractState (ContractState m)) +type UInstanceInfoV m = InstanceInfoTypeV (InstrumentedModuleRef m) (TemporaryContractState (ContractState m) (MBSStore m)) -- | This is a derived notion that is used inside a transaction to keep track of -- the state of the world during execution. Local state of contracts and amounts @@ -471,7 +479,7 @@ class (StaticInformation m, ContractStateOperations m, MonadProtocolVersion m) = -- keep track of changes locally first, and only commit them at the end. -- Instance keeps track of its own address hence we need not provide it -- separately. - withInstanceStateV0 :: UInstanceInfoV m GSWasm.V0 -> UpdatableContractState GSWasm.V0 -> m a -> m a + withInstanceStateV0 :: UInstanceInfoV m GSWasm.V0 -> UpdatableContractState (MBSStore m) GSWasm.V0 -> m a -> m a -- | Execute the code in a temporarily modified environment. This is needed -- in nested calls to transactions which might end up failing at the end. @@ -486,7 +494,7 @@ class (StaticInformation m, ContractStateOperations m, MonadProtocolVersion m) = -- modification index is increased to keep track of changes so that when -- resuming execution a contract is told whether its state has changed or -- not. - withInstanceStateV1 :: UInstanceInfoV m GSWasm.V1 -> UpdatableContractState GSWasm.V1 -> Bool -> (ModificationIndex -> m a) -> m a + withInstanceStateV1 :: UInstanceInfoV m GSWasm.V1 -> UpdatableContractState (MBSStore m) GSWasm.V1 -> Bool -> (ModificationIndex -> m a) -> m a -- | Transfer amount from the first address to the second and run the -- computation in the modified environment. @@ -596,7 +604,7 @@ class (StaticInformation m, ContractStateOperations m, MonadProtocolVersion m) = -- | Get the current contract instance state, together with the modification -- index of the last modification. - getCurrentContractInstanceState :: UInstanceInfoV m GSWasm.V1 -> m (ModificationIndex, TemporaryContractState (ContractState m) GSWasm.V1) + getCurrentContractInstanceState :: UInstanceInfoV m GSWasm.V1 -> m (ModificationIndex, TemporaryContractState (ContractState m) (MBSStore m) GSWasm.V1) -- | Get the current modification index for the instance. If the instance has -- not yet been modified during execution of the transaction 0 is returned. @@ -687,35 +695,35 @@ type ModificationIndex = Word -- That is why we have the auxiliary type definition @InstanceV1Update'@ -- parametrized by the type function @mr@ and then a simplified type alias -- @InstanceV1Update@ on top. -data InstanceV1Update' mr = InstanceV1Update +data InstanceV1Update' store mr = InstanceV1Update { -- | The modification index. index :: !ModificationIndex, -- | Amount changed amountChange :: !AmountDelta, -- | Present if a state change has ocurred. - newState :: !(Maybe (UpdatableContractState GSWasm.V1)), + newState :: !(Maybe (UpdatableContractState store GSWasm.V1)), -- | Present if the contract has been upgraded. -- Contract upgrades are only supported from PV 5 and onwards. newInterface :: !(Maybe (GSWasm.ModuleInterfaceA (mr GSWasm.V1), Set.Set GSWasm.ReceiveName)) } -type InstanceV1Update m = InstanceV1Update' (InstrumentedModuleRef m) +type InstanceV1Update m = InstanceV1Update' (MBSStore m) (InstrumentedModuleRef m) -type ChangeSet m = ChangeSet' (InstrumentedModuleRef m) +type ChangeSet m = ChangeSet' (MBSStore m) (InstrumentedModuleRef m) -- | The set of changes to be committed on a successful transaction. -- -- The reason for parametrizing by a type function @mr@ is the same as for -- @InstanceV1Update@. -data ChangeSet' mr = ChangeSet +data ChangeSet' store mr = ChangeSet { -- | Accounts whose states changed. -- |V0 contracts whose states changed. Any time we are updating a contract we know which version it is. -- We thus know where to look. _accountUpdates :: !(HMap.HashMap AccountIndex AccountUpdate), - _instanceV0Updates :: !(HMap.HashMap ContractAddress (ModificationIndex, AmountDelta, Maybe (UpdatableContractState GSWasm.V0))), + _instanceV0Updates :: !(HMap.HashMap ContractAddress (ModificationIndex, AmountDelta, Maybe (UpdatableContractState store GSWasm.V0))), -- | V1 contracts whose state changed (and/or) has been upgraded. Any time we are updating a contract we know which version it is. -- We thus know where to look. - _instanceV1Updates :: !(HMap.HashMap ContractAddress (InstanceV1Update' mr)), + _instanceV1Updates :: !(HMap.HashMap ContractAddress (InstanceV1Update' store mr)), -- | Contracts that were initialized. _instanceInits :: !(HSet.HashSet ContractAddress), -- | Change in the encrypted balance of the system as a result of this contract's execution. @@ -791,7 +799,14 @@ modifyAmountCS Proxy ai !amnt !cs = cs & (accountUpdates . ix ai . auAmount) %~ upd Nothing = error "modifyAmountCS precondition violated." -- | Add or update the contract state in the changeset with the new state. -addContractStatesToCSV0 :: (HasInstanceAddress a) => Proxy m -> a -> ModificationIndex -> UpdatableContractState GSWasm.V0 -> ChangeSet m -> ChangeSet m +addContractStatesToCSV0 :: + (HasInstanceAddress a) => + Proxy m -> + a -> + ModificationIndex -> + UpdatableContractState (MBSStore m) GSWasm.V0 -> + ChangeSet m -> + ChangeSet m addContractStatesToCSV0 Proxy istance curIdx newState = instanceV0Updates . at addr %~ \case Just (_, amnt, _) -> Just (curIdx, amnt, Just newState) @@ -800,7 +815,14 @@ addContractStatesToCSV0 Proxy istance curIdx newState = addr = instanceAddress istance -- | Add or update the contract state in the changeset with the new state. -addContractStatesToCSV1 :: (HasInstanceAddress a) => Proxy m -> a -> ModificationIndex -> UpdatableContractState GSWasm.V1 -> ChangeSet m -> ChangeSet m +addContractStatesToCSV1 :: + (HasInstanceAddress a) => + Proxy m -> + a -> + ModificationIndex -> + UpdatableContractState (MBSStore m) GSWasm.V1 -> + ChangeSet m -> + ChangeSet m addContractStatesToCSV1 Proxy istance curIdx stateUpdate = instanceV1Updates . at addr @@ -1172,6 +1194,8 @@ instance (StaticInformation m) => StaticInformation (LocalT r m) where {-# INLINE getExchangeRates #-} getExchangeRates = liftLocal getExchangeRates +type instance MBSStore (LocalT r m) = MBSStore m + deriving via (MGSTrans (LocalT r) m) instance (AccountOperations m) => AccountOperations (LocalT r m) deriving via (MGSTrans (LocalT r) m) instance (ContractStateOperations m) => ContractStateOperations (LocalT r m) diff --git a/concordium-consensus/src/Concordium/Scheduler/EnvironmentImplementation.hs b/concordium-consensus/src/Concordium/Scheduler/EnvironmentImplementation.hs index 5f21b790d6..68d3d5d48e 100644 --- a/concordium-consensus/src/Concordium/Scheduler/EnvironmentImplementation.hs +++ b/concordium-consensus/src/Concordium/Scheduler/EnvironmentImplementation.hs @@ -25,6 +25,7 @@ import Concordium.GlobalState.Account import qualified Concordium.GlobalState.BakerInfo as BI import qualified Concordium.GlobalState.BlockState as BS import Concordium.GlobalState.Persistent.Account.ProtocolLevelTokens +import Concordium.GlobalState.Persistent.BlobStore (MBSStore) import Concordium.GlobalState.Persistent.BlockState.ProtocolLevelTokens (PLTConfiguration (..), TokenIndex) import Concordium.GlobalState.TreeState import Concordium.Logger @@ -122,6 +123,8 @@ deriving via instance BlockStateTypes (SchedulerT m) +type instance MBSStore (SchedulerT m) = MBSStore m + instance (BS.BlockStateOperations m) => StaticInformation (SchedulerT m) where {-# INLINE getMaxBlockEnergy #-} getMaxBlockEnergy = view maxBlockEnergy diff --git a/concordium-consensus/src/Concordium/Scheduler/InvokeContract.hs b/concordium-consensus/src/Concordium/Scheduler/InvokeContract.hs index 59ef81d4b2..a468d1eb6b 100644 --- a/concordium-consensus/src/Concordium/Scheduler/InvokeContract.hs +++ b/concordium-consensus/src/Concordium/Scheduler/InvokeContract.hs @@ -37,6 +37,7 @@ import Concordium.Types.InvokeContract (ContractContext (..), InvokeContractResu import qualified Concordium.Wasm as Wasm import qualified Data.FixedByteString as FBS +import Concordium.GlobalState.Persistent.BlobStore (MBSStore) import Concordium.Scheduler import Concordium.Scheduler.Environment import Concordium.Scheduler.EnvironmentImplementation (ContextState (..), accountCreationLimit, chainMetadata, maxBlockEnergy) @@ -62,6 +63,8 @@ newtype InvokeContractMonad m a = InvokeContractMonad {_runInvokeContract :: Rea MonadLogger ) +type instance MBSStore (InvokeContractMonad m) = MBSStore m + deriving instance (Monad m, r ~ BlockState m) => MonadReader (ContextState, r) (InvokeContractMonad m) instance MonadTrans InvokeContractMonad where diff --git a/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs b/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs index 83d41f2d57..300bf533be 100644 --- a/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs +++ b/concordium-consensus/src/Concordium/Scheduler/WasmIntegration/V1.hs @@ -214,7 +214,7 @@ invokeResponseToWord64 (Error (ExecutionReject LogicReject{..})) = foreign import ccall "call_init_v1" call_init :: -- | Callbacks for loading state. Not needed in reality, but the way things are set it is. It does not hurt to pass. - LoadCallback -> + LoadCallback store -> -- | Pointer to the Wasm artifact. Ptr Word8 -> -- | Length of the artifact. @@ -242,14 +242,14 @@ foreign import ccall "call_init_v1" -- | Length of the output byte array, if non-null. Ptr CSize -> -- | Location where the pointer to the mutable state will be written. - Ptr (Ptr StateV1.MutableStateInner) -> + Ptr (Ptr (StateV1.ForeignMutableState store)) -> -- | New state and logs, if applicable, or null, signalling out-of-energy. IO (Ptr Word8) foreign import ccall "call_receive_v1" call_receive :: -- | Callback in case any state needs to be loaded from block state storage. - LoadCallback -> + LoadCallback store -> -- | Pointer to the Wasm artifact. Ptr Word8 -> -- | Length of the artifact. @@ -269,7 +269,7 @@ foreign import ccall "call_receive_v1" -- | Pointer to the current state of the smart contracts. If -- successful, pointer to the new state will be written here if the state has been modified. -- If the state has not been modified then a null pointer is written here. - Ptr (Ptr StateV1.MutableStateInner) -> + Ptr (Ptr (StateV1.ForeignMutableState store)) -> -- | Pointer to the parameter. Ptr Word8 -> -- | Length of the parameter bytes. @@ -300,7 +300,7 @@ foreign import ccall "call_receive_v1" foreign import ccall "resume_receive_v1" resume_receive :: - LoadCallback -> + LoadCallback store -> -- | Location where the pointer to interrupted config will be stored. Ptr (Ptr ReceiveInterruptedState) -> -- | Tag of whether the state has been updated or not. If this is 0 then the state has not been updated, otherwise, it has. @@ -308,7 +308,7 @@ foreign import ccall "resume_receive_v1" -- | Pointer to the current state of the smart contracts. If -- successful, pointer to the new state will be written here if the state has been modified. -- If the state has not been modified then a null pointer is written here. - Ptr (Ptr StateV1.MutableStateInner) -> + Ptr (Ptr (StateV1.ForeignMutableState store)) -> -- | New balance of the contract. Word64 -> -- | Return status from the interrupt. @@ -327,7 +327,7 @@ foreign import ccall "resume_receive_v1" -- | Apply an init function which is assumed to be a part of the module. {-# NOINLINE applyInitFun #-} applyInitFun :: - LoadCallback -> + LoadCallback store -> InstrumentedModuleV V1 -> -- | Chain information available to the contracts. ChainMetadata -> @@ -346,7 +346,7 @@ applyInitFun :: InterpreterEnergy -> -- | Nothing if execution ran out of energy. -- Just (result, remainingEnergy) otherwise, where @remainingEnergy@ is the amount of energy that is left from the amount given. - Maybe (Either ContractExecutionReject InitResultData, InterpreterEnergy) + Maybe (Either ContractExecutionReject (InitResultData store), InterpreterEnergy) applyInitFun cbk miface cm initCtx iName param limitLogsAndRvs amnt iEnergy = unsafePerformIO $ do BSU.unsafeUseAsCStringLen wasmArtifactBytes $ \(wasmArtifactPtr, wasmArtifactLen) -> BSU.unsafeUseAsCStringLen initCtxBytes $ \(initCtxBytesPtr, initCtxBytesLen) -> @@ -457,24 +457,24 @@ getInvokeMethod = n -> fail $ "Unsupported invoke method tag: " ++ show n -- | Data return from the contract in case of successful initialization. -data InitResultData = InitSuccess +data InitResultData store = InitSuccess { irdReturnValue :: !ReturnValue, - irdNewState :: !StateV1.MutableState, + irdNewState :: !(StateV1.MutableState store), irdLogs :: ![ContractEvent] } -- | Data returned from the receive call. In contrast to an init call, a receive call may interrupt. -data ReceiveResultData +data ReceiveResultData store = -- | Execution terminated with success. ReceiveSuccess { rrdReturnValue :: !ReturnValue, - rrdNewState :: !StateV1.MutableState, + rrdNewState :: !(StateV1.MutableState store), rrdStateChanged :: !Bool, rrdLogs :: ![ContractEvent] } | -- | Execution invoked a method. The current state is returned. ReceiveInterrupt - { rrdCurrentState :: !StateV1.MutableState, + { rrdCurrentState :: !(StateV1.MutableState store), rrdStateChanged :: !Bool, rrdMethod :: !InvokeMethod, rrdLogs :: ![ContractEvent], @@ -509,16 +509,16 @@ cerToRejectReasonInit Trap = Exec.RuntimeFailure -- function for the specification of the return value. processInitResult :: -- | State context. - LoadCallback -> + LoadCallback store -> -- | Serialized output. BS.ByteString -> -- | Location where the pointer to the return value is (potentially) stored. Ptr ReturnValue -> -- | Location where the pointer to the initial state is written. - -- |Result, and remaining energy. Returns 'Nothing' if and only if + Ptr (StateV1.ForeignMutableState store) -> + -- | Result, and remaining energy. Returns 'Nothing' if and only if -- execution ran out of energy. - Ptr StateV1.MutableStateInner -> - IO (Maybe (Either ContractExecutionReject InitResultData, InterpreterEnergy)) + IO (Maybe (Either ContractExecutionReject (InitResultData store), InterpreterEnergy)) processInitResult callbacks result returnValuePtr newStatePtr = case BS.uncons result of Nothing -> error "Internal error: Could not parse the result from the interpreter." Just (tag, payload) -> @@ -590,9 +590,9 @@ processReceiveResult :: -- is incorrect in some cases. The latter applies to protocols 4 and 5. Bool -> -- | State context. - LoadCallback -> + LoadCallback store -> -- | State execution started in. - StateV1.MutableState -> + StateV1.MutableState store -> -- | Whether the state was written to. Bool -> -- | Serialized output. @@ -600,12 +600,12 @@ processReceiveResult :: -- | Location where the pointer to the return value is (potentially) stored. Ptr ReturnValue -> -- | Pointer to the state of the contract at the time of termination. - Ptr StateV1.MutableStateInner -> + Ptr (StateV1.ForeignMutableState store) -> -- | Location where the pointer to interrupted config is (potentially) stored. - -- |Result, and remaining energy. Returns 'Nothing' if and only if - -- execution ran out of energy. Either ReceiveInterruptedState (Ptr (Ptr ReceiveInterruptedState)) -> - IO (Maybe (Either ContractExecutionReject ReceiveResultData, InterpreterEnergy)) + -- | Result, and remaining energy. Returns 'Nothing' if and only if + -- execution ran out of energy. + IO (Maybe (Either ContractExecutionReject (ReceiveResultData store), InterpreterEnergy)) processReceiveResult fixRollbacks callbacks initialState stateWrittenTo result returnValuePtr statePtr eitherInterruptedStatePtr = case BS.uncons result of Nothing -> error "Internal error: Could not parse the result from the interpreter." Just (tag, payload) -> do @@ -708,13 +708,13 @@ applyReceiveFun :: -- | Amount the contract is initialized with. Amount -> -- | State of the contract to start in, and a way to use it. - StateV1.MutableState -> + StateV1.MutableState store -> RuntimeConfig -> -- | Amount of energy available for execution. InterpreterEnergy -> -- | Nothing if execution used up all the energy, and otherwise the result -- of execution with the amount of energy remaining. - Maybe (Either ContractExecutionReject ReceiveResultData, InterpreterEnergy) + Maybe (Either ContractExecutionReject (ReceiveResultData store), InterpreterEnergy) applyReceiveFun miface cm receiveCtx rName useFallback param amnt initialState RuntimeConfig{..} initialEnergy = unsafePerformIO $ do BSU.unsafeUseAsCStringLen wasmArtifact $ \(wasmArtifactPtr, wasmArtifactLen) -> BSU.unsafeUseAsCStringLen initCtxBytes $ \(initCtxBytesPtr, initCtxBytesLen) -> @@ -771,7 +771,7 @@ applyReceiveFun miface cm receiveCtx rName useFallback param amnt initialState R resumeReceiveFun :: ReceiveInterruptedState -> -- | State of the contract to resume in. - StateV1.MutableState -> + StateV1.MutableState store -> -- | Whether the state has changed in the call. Bool -> -- | Current balance of the contract, if it changed. @@ -782,7 +782,7 @@ resumeReceiveFun :: InterpreterEnergy -> -- | Nothing if execution used up all the energy, and otherwise the result -- of execution with the amount of energy remaining. - Maybe (Either ContractExecutionReject ReceiveResultData, InterpreterEnergy) + Maybe (Either ContractExecutionReject (ReceiveResultData store), InterpreterEnergy) resumeReceiveFun is currentState stateChanged amnt statusCode rVal remainingEnergy = unsafePerformIO $ do withReceiveInterruptedState is $ \isPtr -> StateV1.withMutableState currentState $ \curStatePtr -> alloca $ \statePtrPtr -> do diff --git a/concordium-consensus/src/Concordium/Skov/Monad.hs b/concordium-consensus/src/Concordium/Skov/Monad.hs index 5c0b9df8b5..27392b1997 100644 --- a/concordium-consensus/src/Concordium/Skov/Monad.hs +++ b/concordium-consensus/src/Concordium/Skov/Monad.hs @@ -5,6 +5,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- The instance `GlobalStateTypes (SkovQueryMonadT m)` technically has a redundant constraint, -- which we allow by supressing this warning. @@ -33,6 +34,7 @@ import Concordium.GlobalState.BlockState (AccountOperations, BlockStateOperation import Concordium.GlobalState.Classes as C import Concordium.GlobalState.Finalization import Concordium.GlobalState.Parameters +import Concordium.GlobalState.Persistent.BlobStore (MBSStore) import Concordium.GlobalState.Statistics (ConsensusStatistics) import Concordium.GlobalState.Transactions import qualified Concordium.GlobalState.TreeState as TS @@ -454,6 +456,8 @@ unlessShutDown a = newtype SkovQueryMonadT m a = SkovQueryMonadT {runSkovQueryMonad :: m a} deriving (Functor, Applicative, Monad, MonadIO) +type instance MBSStore (SkovQueryMonadT m) = MBSStore m + instance MonadTrans SkovQueryMonadT where {- - INLINE lift - -} lift = SkovQueryMonadT diff --git a/concordium-consensus/src/Concordium/Skov/MonadImplementations.hs b/concordium-consensus/src/Concordium/Skov/MonadImplementations.hs index 92f7254ac7..3be616f3db 100644 --- a/concordium-consensus/src/Concordium/Skov/MonadImplementations.hs +++ b/concordium-consensus/src/Concordium/Skov/MonadImplementations.hs @@ -1,6 +1,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingVia #-} +{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE QuantifiedConstraints #-} @@ -53,15 +54,16 @@ import Concordium.TimeMonad import Concordium.TimerMonad -- | Monad that provides: IO, logging, the operation monads of global state and the SkovQueryMonad. -newtype GlobalStateM pv a = GlobalStateM +newtype GlobalStateM store pv a = GlobalStateM { runGlobalStateM :: SkovQueryMonadT ( PersistentTreeStateMonad - (GSState pv) + (GSState store pv) ( PersistentBlockStateMonad + store pv - (GSContext pv) - (RWST (GSContext pv) () (GSState pv) LogIO) + (GSContext store pv) + (RWST (GSContext store pv) () (GSState store pv) LogIO) ) ) a @@ -73,24 +75,32 @@ newtype GlobalStateM pv a = GlobalStateM MonadIO ) -instance (IsProtocolVersion pv) => MonadProtocolVersion (GlobalStateM pv) where - type MPV (GlobalStateM pv) = pv - -deriving instance (IsProtocolVersion pv, IsConsensusV0 pv) => BlockStateTypes (GlobalStateM pv) -deriving instance (IsProtocolVersion pv, IsConsensusV0 pv) => GlobalStateTypes (GlobalStateM pv) -deriving instance (IsProtocolVersion pv, IsConsensusV0 pv) => ContractStateOperations (GlobalStateM pv) -deriving instance (IsProtocolVersion pv, IsConsensusV0 pv) => AccountOperations (GlobalStateM pv) -deriving instance (IsProtocolVersion pv, IsConsensusV0 pv) => ModuleQuery (GlobalStateM pv) -deriving instance (IsProtocolVersion pv, IsConsensusV0 pv) => TokenStateOperations StateV1.MutableState (GlobalStateM pv) -deriving instance (IsProtocolVersion pv, IsConsensusV0 pv) => PLTQuery (PersistentBlockState pv) StateV1.MutableState (GlobalStateM pv) -deriving instance (IsProtocolVersion pv, IsConsensusV0 pv) => PLTQuery (HashedPersistentBlockState pv) StateV1.MutableState (GlobalStateM pv) -deriving instance (IsProtocolVersion pv, IsConsensusV0 pv) => BlockStateQuery (GlobalStateM pv) -deriving instance (IsProtocolVersion pv, IsConsensusV0 pv) => BlockStateOperations (GlobalStateM pv) -deriving instance (IsProtocolVersion pv, IsConsensusV0 pv) => BlockStateStorage (GlobalStateM pv) -deriving instance (IsProtocolVersion pv, IsConsensusV0 pv) => BlockPointerMonad (GlobalStateM pv) -deriving instance (IsProtocolVersion pv, IsConsensusV0 pv) => SkovQueryMonad (GlobalStateM pv) - -evalGlobalStateM :: GlobalStateM pv a -> GSContext pv -> GSState pv -> LogIO a +type instance MBSStore (GlobalStateM store pv) = store + +instance (IsProtocolVersion pv) => MonadProtocolVersion (GlobalStateM store pv) where + type MPV (GlobalStateM store pv) = pv + +deriving instance (IsProtocolVersion pv, IsConsensusV0 pv) => BlockStateTypes (GlobalStateM store pv) +deriving instance (IsProtocolVersion pv, IsConsensusV0 pv) => GlobalStateTypes (GlobalStateM store pv) +deriving instance (IsProtocolVersion pv, IsConsensusV0 pv) => ContractStateOperations (GlobalStateM store pv) +deriving instance (IsProtocolVersion pv, IsConsensusV0 pv) => AccountOperations (GlobalStateM store pv) +deriving instance (IsProtocolVersion pv, IsConsensusV0 pv) => ModuleQuery (GlobalStateM store pv) +deriving instance + (IsProtocolVersion pv, IsConsensusV0 pv) => + TokenStateOperations (StateV1.MutableState store) (GlobalStateM store pv) +deriving instance + (IsProtocolVersion pv, IsConsensusV0 pv) => + PLTQuery (PersistentBlockState store pv) (StateV1.MutableState store) (GlobalStateM store pv) +deriving instance + (IsProtocolVersion pv, IsConsensusV0 pv) => + PLTQuery (HashedPersistentBlockState store pv) (StateV1.MutableState store) (GlobalStateM store pv) +deriving instance (IsProtocolVersion pv, IsConsensusV0 pv) => BlockStateQuery (GlobalStateM store pv) +deriving instance (IsProtocolVersion pv, IsConsensusV0 pv) => BlockStateOperations (GlobalStateM store pv) +deriving instance (IsProtocolVersion pv, IsConsensusV0 pv) => BlockStateStorage (GlobalStateM store pv) +deriving instance (IsProtocolVersion pv, IsConsensusV0 pv) => BlockPointerMonad (GlobalStateM store pv) +deriving instance (IsProtocolVersion pv, IsConsensusV0 pv) => SkovQueryMonad (GlobalStateM store pv) + +evalGlobalStateM :: GlobalStateM store pv a -> GSContext store pv -> GSState store pv -> LogIO a evalGlobalStateM comp gsCtx gsState = fst <$> evalRWST (runPersistentBlockStateMonad . runPersistentTreeStateMonad . runSkovQueryMonad . runGlobalStateM $ comp) gsCtx gsState -- * Handler configuration @@ -137,7 +147,7 @@ instance FinalizationConfig (NoFinalization t) where -- in finalization meant that this instance is not required. instance (Monad m) => - FinalizationOutputMonad (SkovT pv h (SkovConfig pv (NoFinalization t) hc) m) + FinalizationOutputMonad (SkovT store pv h (SkovConfig pv (NoFinalization t) hc) m) where broadcastFinalizationPseudoMessage _ = return () @@ -154,7 +164,7 @@ instance FinalizationConfig (ActiveFinalization t) where instance (SkovFinalizationHandlers h m, Monad m) => - FinalizationOutputMonad (SkovT pv h (SkovConfig pv (ActiveFinalization t) hc) m) + FinalizationOutputMonad (SkovT store pv h (SkovConfig pv (ActiveFinalization t) hc) m) where broadcastFinalizationPseudoMessage pmsg = do h <- askHandler @@ -174,8 +184,8 @@ instance FinalizationConfig (BufferedFinalization t) where return (finInst, BufferedFinalizationState finalizationState emptyFinalizationBuffer) instance - (SkovFinalizationHandlers h m, Monad m, TimeMonad m, MonadLogger m, SkovTimerHandlers pv h (SkovConfig pv (BufferedFinalization t) hc) m) => - FinalizationOutputMonad (SkovT pv h (SkovConfig pv (BufferedFinalization t) hc) m) + (SkovFinalizationHandlers h m, Monad m, TimeMonad m, MonadLogger m, SkovTimerHandlers store pv h (SkovConfig pv (BufferedFinalization t) hc) m) => + FinalizationOutputMonad (SkovT store pv h (SkovConfig pv (BufferedFinalization t) hc) m) where broadcastFinalizationMessage = bufferFinalizationMessage @@ -197,28 +207,32 @@ instance -- * @finconfig@: the finalization configuration. Currently supported types are @NoFinalization t@, -- @ActiveFinalization t@ and @BufferedFinalization t@, where @t@ is the type of timers in the supporting monad. -- * @handlerconfig@ is the type of event handlers. Currently supported types are @NoHandlers@ and @LogUpdateHandlers@. -data SkovConfig (pv :: ProtocolVersion) finconfig handlerconfig = SkovConfig !GlobalStateConfig !finconfig !handlerconfig +data SkovConfig (pv :: ProtocolVersion) finconfig handlerconfig + = SkovConfig !GlobalStateConfig !finconfig !handlerconfig -- | The type of contexts (i.e. read only data) for the skov configuration type. -data family SkovContext c +data family SkovContext store c -data instance SkovContext (SkovConfig pv finconf hconf) = SkovContext - { scGSContext :: !(GSContext pv), +data instance SkovContext store (SkovConfig pv finconf hconf) = SkovContext + { scGSContext :: !(GSContext store pv), scFinContext :: !(FCContext finconf), scHandlerContext :: !(HCContext hconf) } -- | The type of states (i.e. mutable data) for the skov configuration type. -data family SkovState c +data family SkovState store c -data instance SkovState (SkovConfig pv finconf hconf) = SkovState - { ssGSState :: !(GSState pv), +data instance SkovState store (SkovConfig pv finconf hconf) = SkovState + { ssGSState :: !(GSState store pv), ssFinState :: !(FCState finconf), ssHandlerState :: !(HCState hconf) } -- | A pair of 'SkovContext' and 'SkovState' for a given 'SkovConfig' determined by the type parameters. -type InitialisedSkov pv finconfig handlerconfig = (SkovContext (SkovConfig pv finconfig handlerconfig), SkovState (SkovConfig pv finconfig handlerconfig)) +data InitialisedSkov pv finconfig handlerconfig + = forall store. InitialisedSkov + (SkovContext store (SkovConfig pv finconfig handlerconfig)) + (SkovState store (SkovConfig pv finconfig handlerconfig)) class SkovConfiguration finconfig handlerconfig where -- | Create an initial context and state from a given configuration. The @@ -241,7 +255,7 @@ class SkovConfiguration finconfig handlerconfig where (IsProtocolVersion pv, IsConsensusV0 pv) => GenesisData pv -> SkovConfig pv finconfig handlerconfig -> - LogIO (SkovContext (SkovConfig pv finconfig handlerconfig), SkovState (SkovConfig pv finconfig handlerconfig)) + LogIO (InitialisedSkov pv finconfig handlerconfig) -- | Migrate an existing skov instance to a fresh one. This is used on -- protocol updates to construct a new instance to be used after the @@ -254,21 +268,18 @@ class SkovConfiguration finconfig handlerconfig where migrateExistingSkov :: (IsProtocolVersion oldpv, IsConsensusV0 oldpv, IsProtocolVersion pv, IsConsensusV0 pv) => -- | Context for the existing skov instance. - SkovContext (SkovConfig oldpv finconfig handlerconfig) -> + SkovContext oldstore (SkovConfig oldpv finconfig handlerconfig) -> -- | State of the existing skov instance. This must be prepared for -- migration. See @rememberFinalState@ and @clearSkovOnProtocolUpdate@, and -- @migrateExistingState@ for details on the assumptions on this state. - SkovState (SkovConfig oldpv finconfig handlerconfig) -> + SkovState oldstore (SkovConfig oldpv finconfig handlerconfig) -> -- | Any parameters needed for the migration of the block state. StateMigrationParameters oldpv pv -> -- | The genesis for the new chain after the protocol update. Regenesis pv -> -- | Configuration for the new chain after the protocol update. SkovConfig pv finconfig handlerconfig -> - LogIO - ( SkovContext (SkovConfig pv finconfig handlerconfig), - SkovState (SkovConfig pv finconfig handlerconfig) - ) + LogIO (InitialisedSkov pv finconfig handlerconfig) -- | A helper which attemps to use the existing state if it exists, and -- otherwise initialises skov from a new state created from the given genesis. @@ -276,7 +287,7 @@ class SkovConfiguration finconfig handlerconfig where (IsProtocolVersion pv, IsConsensusV0 pv) => GenesisData pv -> SkovConfig pv finconfig handlerconfig -> - LogIO (SkovContext (SkovConfig pv finconfig handlerconfig), SkovState (SkovConfig pv finconfig handlerconfig)) + LogIO (InitialisedSkov pv finconfig handlerconfig) initialiseSkov gd cfg = initialiseExistingSkov cfg >>= \case Nothing -> initialiseNewSkov gd cfg @@ -286,98 +297,108 @@ class SkovConfiguration finconfig handlerconfig where -- the state can be used by consensus for anything other than queries. activateSkovState :: (IsProtocolVersion pv, IsConsensusV0 pv) => - SkovContext (SkovConfig pv finconfig handlerconfig) -> - SkovState (SkovConfig pv finconfig handlerconfig) -> - LogIO (SkovState (SkovConfig pv finconfig handlerconfig)) + SkovContext store (SkovConfig pv finconfig handlerconfig) -> + SkovState store (SkovConfig pv finconfig handlerconfig) -> + LogIO (SkovState store (SkovConfig pv finconfig handlerconfig)) -- | Free any resources when we are done with the context and state. - shutdownSkov :: (IsProtocolVersion pv, IsConsensusV0 pv) => SkovContext (SkovConfig pv finconfig handlerconfig) -> SkovState (SkovConfig pv finconfig handlerconfig) -> LogIO () + shutdownSkov :: + (IsProtocolVersion pv, IsConsensusV0 pv) => + SkovContext store (SkovConfig pv finconfig handlerconfig) -> + SkovState store (SkovConfig pv finconfig handlerconfig) -> + LogIO () instance ( FinalizationConfig finconfig, HandlerConfig handlerconfig, Show (FCContext finconfig), Show (FCState finconfig), - forall pv. + forall store pv. (IsProtocolVersion pv, IsConsensusV0 pv) => - SkovQueryMonad (GlobalStateM pv) + SkovQueryMonad (GlobalStateM store pv) ) => SkovConfiguration finconfig handlerconfig where + -- initialiseExistingSkov :: + -- forall pv. + -- (IsProtocolVersion pv, IsConsensusV0 pv) => + -- SkovConfig pv finconfig handlerconfig -> + -- LogIO (Maybe (SkovContext store (SkovConfig pv finconfig handlerconfig), SkovState store (SkovConfig pv finconfig handlerconfig))) initialiseExistingSkov :: forall pv. (IsProtocolVersion pv, IsConsensusV0 pv) => SkovConfig pv finconfig handlerconfig -> - LogIO (Maybe (SkovContext (SkovConfig pv finconfig handlerconfig), SkovState (SkovConfig pv finconfig handlerconfig))) + LogIO (Maybe (InitialisedSkov pv finconfig handlerconfig)) initialiseExistingSkov (SkovConfig gsc finconf hconf) = do logEvent Skov LLDebug "Attempting to use existing global state." initialiseExistingGlobalState (protocolVersion @pv) gsc >>= \case Nothing -> do logEvent Skov LLDebug "No existing global state." return Nothing - Just (c, s) -> do - (finctx, finst) <- evalGlobalStateM @pv (initialiseFinalization finconf) c s + Just (InitialisedState c s) -> do + (finctx, finst) <- evalGlobalStateM @_ @pv (initialiseFinalization finconf) c s logEvent Skov LLDebug $ "Initializing finalization with context = " ++ show finctx logEvent Skov LLDebug $ "Initializing finalization with initial state = " ++ show finst let (hctx, hst) = initialiseHandler hconf - return (Just (SkovContext c finctx hctx, SkovState s finst hst)) + return (Just (InitialisedSkov (SkovContext c finctx hctx) (SkovState s finst hst))) initialiseNewSkov :: forall pv. (IsProtocolVersion pv, IsConsensusV0 pv) => GenesisData pv -> SkovConfig pv finconfig handlerconfig -> - LogIO (SkovContext (SkovConfig pv finconfig handlerconfig), SkovState (SkovConfig pv finconfig handlerconfig)) + LogIO (InitialisedSkov pv finconfig handlerconfig) initialiseNewSkov genData (SkovConfig gsc finconf hconf) = do logEvent Skov LLDebug "Creating new global state." - (c, s) <- initialiseNewGlobalState genData gsc - (finctx, finst) <- evalGlobalStateM @pv (initialiseFinalization finconf) c s + (InitialisedState c s) <- initialiseNewGlobalState genData gsc + (finctx, finst) <- evalGlobalStateM @_ @pv (initialiseFinalization finconf) c s logEvent Skov LLDebug $ "Initializing finalization with context = " ++ show finctx logEvent Skov LLDebug $ "Initializing finalization with initial state = " ++ show finst let (hctx, hst) = initialiseHandler hconf - return (SkovContext c finctx hctx, SkovState s finst hst) + return (InitialisedSkov (SkovContext c finctx hctx) (SkovState s finst hst)) migrateExistingSkov :: - forall oldpv pv. + forall oldstore oldpv pv. (IsProtocolVersion oldpv, IsConsensusV0 oldpv, IsProtocolVersion pv, IsConsensusV0 pv) => - SkovContext (SkovConfig oldpv finconfig handlerconfig) -> - SkovState (SkovConfig oldpv finconfig handlerconfig) -> + SkovContext oldstore (SkovConfig oldpv finconfig handlerconfig) -> + SkovState oldstore (SkovConfig oldpv finconfig handlerconfig) -> StateMigrationParameters oldpv pv -> Regenesis pv -> SkovConfig pv finconfig handlerconfig -> - LogIO - ( SkovContext (SkovConfig pv finconfig handlerconfig), - SkovState (SkovConfig pv finconfig handlerconfig) - ) + LogIO (InitialisedSkov pv finconfig handlerconfig) migrateExistingSkov oldCtx oldState migration genData (SkovConfig gsc finconf hconf) = do logEvent Skov LLDebug "Migrating existing global state." - (c, s) <- migrateExistingState gsc (scGSContext oldCtx) (ssGSState oldState) migration genData - (finctx, finst) <- evalGlobalStateM @pv (initialiseFinalization finconf) c s + (InitialisedState c s) <- migrateExistingState gsc (scGSContext oldCtx) (ssGSState oldState) migration genData + (finctx, finst) <- evalGlobalStateM @_ @pv (initialiseFinalization finconf) c s logEvent Skov LLDebug $ "Initializing finalization with context = " ++ show finctx logEvent Skov LLDebug $ "Initializing finalization with initial state = " ++ show finst let (hctx, hst) = initialiseHandler hconf - return (SkovContext c finctx hctx, SkovState s finst hst) + return (InitialisedSkov (SkovContext c finctx hctx) (SkovState s finst hst)) activateSkovState :: - forall pv. + forall store pv. (IsProtocolVersion pv, IsConsensusV0 pv) => - SkovContext (SkovConfig pv finconfig handlerconfig) -> - SkovState (SkovConfig pv finconfig handlerconfig) -> - LogIO (SkovState (SkovConfig pv finconfig handlerconfig)) + SkovContext store (SkovConfig pv finconfig handlerconfig) -> + SkovState store (SkovConfig pv finconfig handlerconfig) -> + LogIO (SkovState store (SkovConfig pv finconfig handlerconfig)) activateSkovState skovContext skovState = do activatedState <- activateGlobalState (Proxy @pv) (scGSContext skovContext) (ssGSState skovState) return skovState{ssGSState = activatedState} - shutdownSkov :: forall pv. (IsProtocolVersion pv, IsConsensusV0 pv) => SkovContext (SkovConfig pv finconfig handlerconfig) -> SkovState (SkovConfig pv finconfig handlerconfig) -> LogIO () + + shutdownSkov :: + forall store pv. + (IsProtocolVersion pv, IsConsensusV0 pv) => + SkovContext store (SkovConfig pv finconfig handlerconfig) -> SkovState store (SkovConfig pv finconfig handlerconfig) -> LogIO () shutdownSkov (SkovContext c _ _) (SkovState s _ _) = liftIO $ shutdownGlobalState (protocolVersion @pv) c s -- | An instance of 'SkovTimerHandlers' provides a means for implementing -- a 'TimerMonad' instance for 'SkovT'. -class SkovTimerHandlers pv h c m | h -> pv m c where +class SkovTimerHandlers store pv h c m | h -> store pv m c where -- | Type to represent a timer type SkovHandlerTimer h -- | Handler for creating a timer event - handleOnTimeout :: h -> Timeout -> SkovT pv h c m a -> m (SkovHandlerTimer h) + handleOnTimeout :: h -> Timeout -> SkovT store pv h c m a -> m (SkovHandlerTimer h) -- | Handler for cancelling a timer handleCancelTimer :: h -> SkovHandlerTimer h -> m () @@ -399,36 +420,36 @@ class SkovPendingLiveHandlers h m where -- | 'SkovHandlers' provides an implementation of 'SkovTimerHandlers' and -- 'SkovFinalizationHandlers'. -data SkovHandlers pv t c m = SkovHandlers +data SkovHandlers store pv t c m = SkovHandlers { shBroadcastFinalizationMessage :: FinalizationPseudoMessage -> m (), - shOnTimeout :: forall a. Timeout -> SkovT pv (SkovHandlers pv t c m) c m a -> m t, + shOnTimeout :: forall a. Timeout -> SkovT store pv (SkovHandlers store pv t c m) c m a -> m t, shCancelTimer :: t -> m (), shPendingLive :: m () } -instance SkovFinalizationHandlers (SkovHandlers pv t c m) m where +instance SkovFinalizationHandlers (SkovHandlers store pv t c m) m where handleBroadcastFinalizationMessage SkovHandlers{..} = shBroadcastFinalizationMessage -instance SkovTimerHandlers pv (SkovHandlers pv t c m) c m where - type SkovHandlerTimer (SkovHandlers pv t c m) = t +instance SkovTimerHandlers store pv (SkovHandlers store pv t c m) c m where + type SkovHandlerTimer (SkovHandlers store pv t c m) = t handleOnTimeout SkovHandlers{..} = shOnTimeout handleCancelTimer SkovHandlers{..} = shCancelTimer -instance SkovPendingLiveHandlers (SkovHandlers pv t c m) m where +instance SkovPendingLiveHandlers (SkovHandlers store pv t c m) m where handlePendingLive = shPendingLive -newtype SkovPassiveHandlers (pv :: ProtocolVersion) (c :: Type) m = SkovPassiveHandlers +newtype SkovPassiveHandlers store (pv :: ProtocolVersion) (c :: Type) m = SkovPassiveHandlers { sphPendingLive :: m () } -instance SkovPendingLiveHandlers (SkovPassiveHandlers pv c m) m where +instance SkovPendingLiveHandlers (SkovPassiveHandlers store pv c m) m where handlePendingLive = sphPendingLive -- This provides an instance of timer handlers that should not be used. -- TODO: In future, the types in finalization should be refined so that -- this instance is not needed. -instance SkovTimerHandlers pv (SkovPassiveHandlers pv c m) c m where - type SkovHandlerTimer (SkovPassiveHandlers pv c m) = () +instance SkovTimerHandlers store pv (SkovPassiveHandlers store pv c m) c m where + type SkovHandlerTimer (SkovPassiveHandlers store pv c m) = () handleOnTimeout _ _ _ = error "Attempted to set a timer, but SkovPassiveHandlers does not support timers." handleCancelTimer _ _ = error "Attempted to cancel a timer, but SkovPassiveHandlers does not support timers." @@ -450,14 +471,15 @@ data SkovTContext h c = SkovTContext -- * @m@: the underlying monad. Typically, this should be an instance of 'MonadIO', 'MonadLogger', -- and 'TimeMonad'. -- * @a@: the return type. -newtype SkovT pv h c m a = SkovT +newtype SkovT store pv h c m a = SkovT { runSkovT' :: PersistentTreeStateMonad - (SkovState c) + (SkovState store c) ( PersistentBlockStateMonad + store pv - (SkovTContext h (SkovContext c)) - (RWST (SkovTContext h (SkovContext c)) () (SkovState c) m) + (SkovTContext h (SkovContext store c)) + (RWST (SkovTContext h (SkovContext store c)) () (SkovState store c) m) ) a } @@ -465,14 +487,16 @@ newtype SkovT pv h c m a = SkovT ( Functor, Applicative, Monad, - MonadState (SkovState c), + MonadState (SkovState store c), MonadIO, MonadLogger, TimeMonad, BlockStateTypes ) -runSkovT :: (Monad m) => SkovT pv h c m a -> h -> SkovContext c -> SkovState c -> m (a, SkovState c) +type instance MBSStore (SkovT store pv h c m) = store + +runSkovT :: (Monad m) => SkovT store pv h c m a -> h -> SkovContext store c -> SkovState store c -> m (a, SkovState store c) runSkovT comp h context sstate = do (a, s, _) <- runRWST @@ -481,22 +505,22 @@ runSkovT comp h context sstate = do sstate return (a, s) -evalSkovT :: (Monad m) => SkovT pv h c m a -> h -> SkovContext c -> SkovState c -> m a +evalSkovT :: (Monad m) => SkovT store pv h c m a -> h -> SkovContext store c -> SkovState store c -> m a evalSkovT comp handler context sstate = fst <$> runSkovT comp handler context sstate -- | Get the handler from the context. -askHandler :: (Monad m) => SkovT pv h c m h +askHandler :: (Monad m) => SkovT store pv h c m h askHandler = SkovT $ PersistentTreeStateMonad $ PersistentBlockStateMonad $ asks srHandler -instance (Monad m) => MonadReader (SkovTContext h (SkovContext c)) (SkovT pv h c m) where +instance (Monad m) => MonadReader (SkovTContext h (SkovContext store c)) (SkovT store pv h c m) where ask = SkovT $ PersistentTreeStateMonad ask local f (SkovT (PersistentTreeStateMonad a)) = SkovT $ PersistentTreeStateMonad $ local f a -instance MonadTrans (SkovT pv h c) where +instance MonadTrans (SkovT store pv h c) where lift a = SkovT $ PersistentTreeStateMonad $ PersistentBlockStateMonad $ lift a -instance (Monad m, SkovTimerHandlers pv h c m) => TimerMonad (SkovT pv h c m) where - type Timer (SkovT pv h c m) = SkovHandlerTimer h +instance (Monad m, SkovTimerHandlers store pv h c m) => TimerMonad (SkovT store pv h c m) where + type Timer (SkovT store pv h c m) = SkovHandlerTimer h onTimeout timeout a = do h <- askHandler lift (handleOnTimeout h timeout a) @@ -504,35 +528,38 @@ instance (Monad m, SkovTimerHandlers pv h c m) => TimerMonad (SkovT pv h c m) wh h <- askHandler lift (handleCancelTimer h t) -instance (IsProtocolVersion pv) => MonadProtocolVersion (SkovT pv h c' m) where - type MPV (SkovT pv h c' m) = pv +instance (IsProtocolVersion pv) => MonadProtocolVersion (SkovT store pv h c' m) where + type MPV (SkovT store pv h c' m) = pv -instance (c ~ SkovConfig pv finconfig handlerconfig) => HasBlobStore (SkovContext c) where +instance (c ~ SkovConfig pv finconfig handlerconfig) => HasBlobStore store (SkovContext store c) where blobStore = blobStore . scGSContext blobLoadCallback = blobLoadCallback . scGSContext blobStoreCallback = blobStoreCallback . scGSContext -instance (c ~ SkovConfig pv finconfig handlerconfig, AccountVersionFor pv ~ av) => HasCache (AccountCache av) (SkovContext c) where +instance (c ~ SkovConfig pv finconfig handlerconfig, AccountVersionFor pv ~ av) => HasCache (AccountCache store av) (SkovContext store c) where projectCache = projectCache . scGSContext -instance (c ~ SkovConfig pv finconfig handlerconfig) => HasCache ModuleCache (SkovContext c) where +instance (c ~ SkovConfig pv finconfig handlerconfig) => HasCache (ModuleCache store) (SkovContext store c) where projectCache = projectCache . scGSContext -instance (c ~ SkovConfig pv finconfig handlerconfig) => HasBlobStore (SkovTContext h (SkovContext c)) where +instance (c ~ SkovConfig pv finconfig handlerconfig) => HasBlobStore store (SkovTContext h (SkovContext store c)) where blobStore = blobStore . srContext blobLoadCallback = blobLoadCallback . srContext blobStoreCallback = blobStoreCallback . srContext -instance (c ~ SkovConfig pv finconfig handlerconfig, AccountVersionFor pv ~ av) => HasCache (AccountCache av) (SkovTContext h (SkovContext c)) where +instance + (c ~ SkovConfig pv finconfig handlerconfig, AccountVersionFor pv ~ av) => + HasCache (AccountCache store av) (SkovTContext h (SkovContext store c)) + where projectCache = projectCache . srContext -instance (c ~ SkovConfig pv finconfig handlerconfig) => HasCache ModuleCache (SkovTContext h (SkovContext c)) where +instance (c ~ SkovConfig pv finconfig handlerconfig) => HasCache (ModuleCache store) (SkovTContext h (SkovContext store c)) where projectCache = projectCache . srContext -instance (c ~ SkovConfig pv finconfig handlerconfig) => LMDBAccountMap.HasDatabaseHandlers (SkovContext c) where +instance (c ~ SkovConfig pv finconfig handlerconfig) => LMDBAccountMap.HasDatabaseHandlers (SkovContext store 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 +instance (c ~ SkovConfig pv finconfig handlerconfig) => LMDBAccountMap.HasDatabaseHandlers (SkovTContext h (SkovContext store c)) where databaseHandlers = lens srContext (\s v -> s{srContext = v}) . LMDBAccountMap.databaseHandlers deriving instance @@ -541,7 +568,7 @@ deriving instance MonadLogger m, c ~ SkovConfig pv finconfig handlerconfig ) => - TokenStateOperations StateV1.MutableState (SkovT pv h c m) + TokenStateOperations (StateV1.MutableState store) (SkovT store pv h c m) deriving instance ( IsProtocolVersion pv, @@ -549,7 +576,7 @@ deriving instance MonadLogger m, c ~ SkovConfig pv finconfig handlerconfig ) => - PLTQuery (PersistentBlockState pv) StateV1.MutableState (SkovT pv h c m) + PLTQuery (PersistentBlockState store pv) (StateV1.MutableState store) (SkovT store pv h c m) deriving instance ( IsProtocolVersion pv, @@ -557,7 +584,7 @@ deriving instance MonadLogger m, c ~ SkovConfig pv finconfig handlerconfig ) => - PLTQuery (HashedPersistentBlockState pv) StateV1.MutableState (SkovT pv h c m) + PLTQuery (HashedPersistentBlockState store pv) (StateV1.MutableState store) (SkovT store pv h c m) deriving instance ( IsProtocolVersion pv, @@ -565,7 +592,7 @@ deriving instance MonadLogger m, c ~ SkovConfig pv finconfig handlerconfig ) => - BlockStateQuery (SkovT pv h c m) + BlockStateQuery (SkovT store pv h c m) deriving instance ( MonadIO m, @@ -573,7 +600,7 @@ deriving instance MonadLogger m, c ~ SkovConfig pv finconfig handlerconfig ) => - AccountOperations (SkovT pv h c m) + AccountOperations (SkovT store pv h c m) deriving instance ( MonadIO m, @@ -581,7 +608,7 @@ deriving instance MonadLogger m, c ~ SkovConfig pv finconfig handlerconfig ) => - ContractStateOperations (SkovT pv h c m) + ContractStateOperations (SkovT store pv h c m) deriving instance ( MonadIO m, @@ -589,7 +616,7 @@ deriving instance MonadLogger m, c ~ SkovConfig pv finconfig handlerconfig ) => - ModuleQuery (SkovT pv h c m) + ModuleQuery (SkovT store pv h c m) deriving instance ( IsProtocolVersion pv, @@ -597,7 +624,7 @@ deriving instance MonadLogger m, c ~ SkovConfig pv finconfig handlerconfig ) => - BlockStateOperations (SkovT pv h c m) + BlockStateOperations (SkovT store pv h c m) deriving instance ( IsProtocolVersion pv, @@ -605,11 +632,11 @@ deriving instance MonadLogger m, c ~ SkovConfig pv finconfig handlerconfig ) => - BlockStateStorage (SkovT pv h c m) + BlockStateStorage (SkovT store pv h c m) deriving instance (IsProtocolVersion pv) => - GlobalStateTypes (SkovT pv h c m) + GlobalStateTypes (SkovT store pv h c m) deriving instance ( MonadIO m, @@ -617,12 +644,15 @@ deriving instance c ~ SkovConfig pv finconfig handlerconfig, MonadLogger m ) => - BlockPointerMonad (SkovT pv h c m) + BlockPointerMonad (SkovT store pv h c m) -instance (c ~ SkovConfig pv finconfig handlerconfig, st ~ BlockStatePointer (PersistentBlockState pv)) => HasDatabaseHandlers pv st (SkovState c) where +instance + (c ~ SkovConfig pv finconfig handlerconfig, st ~ BlockStatePointer (PersistentBlockState store pv)) => + HasDatabaseHandlers pv st (SkovState store c) + where dbHandlers = lens ssGSState (\s v -> s{ssGSState = v}) . db -instance (c ~ SkovConfig pv finconfig handlerconfig) => HasSkovPersistentData pv (SkovState c) where +instance (c ~ SkovConfig pv finconfig handlerconfig) => HasSkovPersistentData store pv (SkovState store c) where skovPersistentData = lens ssGSState (\s v -> s{ssGSState = v}) deriving instance @@ -631,7 +661,7 @@ deriving instance c ~ SkovConfig pv finconfig handlerconfig, MonadLogger m ) => - AccountNonceQuery (SkovT pv h c m) + AccountNonceQuery (SkovT store pv h c m) deriving instance ( MonadIO m, @@ -639,34 +669,34 @@ deriving instance c ~ SkovConfig pv finconfig handlerconfig, MonadLogger m ) => - TreeStateMonad (SkovT pv h c m) + TreeStateMonad (SkovT store pv h c m) deriving via - SkovQueryMonadT (SkovT pv h c m) + SkovQueryMonadT (SkovT store pv h c m) instance ( IsProtocolVersion pv, IsConsensusV0 pv, Monad m, TimeMonad m, c ~ SkovConfig pv finconfig handlerconfig, - BlockStateQuery (SkovT pv h c m), - BlockPointerMonad (SkovT pv h c m), - TreeStateMonad (SkovT pv h c m) + BlockStateQuery (SkovT store pv h c m), + BlockPointerMonad (SkovT store pv h c m), + TreeStateMonad (SkovT store pv h c m) ) => - SkovQueryMonad (SkovT pv h c m) + SkovQueryMonad (SkovT store pv h c m) instance ( Monad m, TimeMonad m, MonadLogger m, c ~ SkovConfig pv finconfig handlerconfig, - OnSkov (SkovT pv h c m), - BlockStateStorage (SkovT pv h c m), - TreeStateMonad (SkovT pv h c m), - FinalizationMonad (SkovT pv h c m), + OnSkov (SkovT store pv h c m), + BlockStateStorage (SkovT store pv h c m), + TreeStateMonad (SkovT store pv h c m), + FinalizationMonad (SkovT store pv h c m), IsConsensusV0 pv ) => - SkovMonad (SkovT pv h c m) + SkovMonad (SkovT store pv h c m) where receiveBlock = doReceiveBlock executeBlock = doExecuteBlock @@ -698,53 +728,53 @@ instance HandlerConfig NoHandler where type HCState NoHandler = () initialiseHandler = \_ -> ((), ()) -instance (Monad m) => HandlerConfigHandlers NoHandler (SkovT pv h (SkovConfig pv fc NoHandler) m) where +instance (Monad m) => HandlerConfigHandlers NoHandler (SkovT store pv h (SkovConfig pv fc NoHandler) m) where handleBlock = \_ -> return () handleFinalize = \_ _ _ -> return () instance (FinalizationQueueLenses (FCState finconf)) => - FinalizationQueueLenses (SkovState (SkovConfig pv finconf hconf)) + FinalizationQueueLenses (SkovState store (SkovConfig pv finconf hconf)) where finQueue = lens ssFinState (\s fs -> s{ssFinState = fs}) . finQueue instance (FinalizationStateLenses (FCState finconf) t) => - FinalizationStateLenses (SkovState (SkovConfig pv finconf hconf)) t + FinalizationStateLenses (SkovState store (SkovConfig pv finconf hconf)) t where finState = lens ssFinState (\s fs -> s{ssFinState = fs}) . finState instance (FinalizationBufferLenses (FCState finconf)) => - FinalizationBufferLenses (SkovState (SkovConfig pv finconf hconf)) + FinalizationBufferLenses (SkovState store (SkovConfig pv finconf hconf)) where finBuffer = lens ssFinState (\s fs -> s{ssFinState = fs}) . finBuffer instance (HasFinalizationInstance (FCContext finconf)) => - HasFinalizationInstance (SkovContext (SkovConfig pv finconf hconf)) + HasFinalizationInstance (SkovContext store (SkovConfig pv finconf hconf)) where finalizationInstance = finalizationInstance . scFinContext instance (HasFinalizationInstance (FCContext finconf)) => - HasFinalizationInstance (SkovTContext h (SkovContext (SkovConfig pv finconf hconf))) + HasFinalizationInstance (SkovTContext h (SkovContext store (SkovConfig pv finconf hconf))) where finalizationInstance = finalizationInstance . srContext -instance HasGlobalStateContext (GSContext pv) (SkovContext (SkovConfig pv finconf hconf)) where +instance HasGlobalStateContext (GSContext store pv) (SkovContext store (SkovConfig pv finconf hconf)) where globalStateContext = lens scGSContext (\sc v -> sc{scGSContext = v}) -instance HasGlobalState (GSState pv) (SkovState (SkovConfig pv finconf hconf)) where +instance HasGlobalState (GSState store pv) (SkovState store (SkovConfig pv finconf hconf)) where globalState = lens ssGSState (\ss v -> ss{ssGSState = v}) instance ( MonadIO m, c ~ SkovConfig pv finconf hconf, - HandlerConfigHandlers hconf (SkovT pv h c m), + HandlerConfigHandlers hconf (SkovT store pv h c m), SkovPendingLiveHandlers h m ) => - OnSkov (SkovT pv h c m) + OnSkov (SkovT store pv h c m) where onBlock bp = handleBlock bp onFinalize = handleFinalize @@ -760,43 +790,43 @@ instance -- * @hc@: handler configuration type -- * @h@: handler type -- * @m@: base monad -type ActiveFinalizationMWith pv fc hc h m = +type ActiveFinalizationMWith store pv fc hc h m = ActiveFinalizationM pv - (SkovTContext h (SkovContext (SkovConfig pv fc hc))) - (SkovState (SkovConfig pv fc hc)) - (SkovT pv h (SkovConfig pv fc hc) m) + (SkovTContext h (SkovContext store (SkovConfig pv fc hc))) + (SkovState store (SkovConfig pv fc hc)) + (SkovT store pv h (SkovConfig pv fc hc) m) deriving via - (ActiveFinalizationMWith pv (NoFinalization t) hc h m) + (ActiveFinalizationMWith store pv (NoFinalization t) hc h m) instance ( t ~ SkovHandlerTimer h, MonadIO m, - SkovMonad (SkovT pv h (SkovConfig pv (NoFinalization t) hc) m), - SkovTimerHandlers pv h (SkovConfig pv (NoFinalization t) hc) m + SkovMonad (SkovT store pv h (SkovConfig pv (NoFinalization t) hc) m), + SkovTimerHandlers store pv h (SkovConfig pv (NoFinalization t) hc) m ) => - FinalizationMonad (SkovT pv h (SkovConfig pv (NoFinalization t) hc) m) + FinalizationMonad (SkovT store pv h (SkovConfig pv (NoFinalization t) hc) m) deriving via - (ActiveFinalizationMWith pv (ActiveFinalization t) hc h m) + (ActiveFinalizationMWith store pv (ActiveFinalization t) hc h m) instance ( t ~ SkovHandlerTimer h, MonadIO m, - SkovMonad (SkovT pv h (SkovConfig pv (ActiveFinalization t) hc) m), - SkovTimerHandlers pv h (SkovConfig pv (ActiveFinalization t) hc) m, + SkovMonad (SkovT store pv h (SkovConfig pv (ActiveFinalization t) hc) m), + SkovTimerHandlers store pv h (SkovConfig pv (ActiveFinalization t) hc) m, SkovFinalizationHandlers h m ) => - FinalizationMonad (SkovT pv h (SkovConfig pv (ActiveFinalization t) hc) m) + FinalizationMonad (SkovT store pv h (SkovConfig pv (ActiveFinalization t) hc) m) deriving via - (ActiveFinalizationMWith pv (BufferedFinalization t) hc h m) + (ActiveFinalizationMWith store pv (BufferedFinalization t) hc h m) instance ( t ~ SkovHandlerTimer h, MonadIO m, TimeMonad m, MonadLogger m, - SkovMonad (SkovT pv h (SkovConfig pv (BufferedFinalization t) hc) m), - SkovTimerHandlers pv h (SkovConfig pv (BufferedFinalization t) hc) m, + SkovMonad (SkovT store pv h (SkovConfig pv (BufferedFinalization t) hc) m), + SkovTimerHandlers store pv h (SkovConfig pv (BufferedFinalization t) hc) m, SkovFinalizationHandlers h m ) => - FinalizationMonad (SkovT pv h (SkovConfig pv (BufferedFinalization t) hc) m) + FinalizationMonad (SkovT store pv h (SkovConfig pv (BufferedFinalization t) hc) m) diff --git a/concordium-consensus/test-runners/deterministic/Main.hs b/concordium-consensus/test-runners/deterministic/Main.hs index 93ea2f92be..721a82c5fa 100644 --- a/concordium-consensus/test-runners/deterministic/Main.hs +++ b/concordium-consensus/test-runners/deterministic/Main.hs @@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GeneralisedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} @@ -162,11 +163,11 @@ instance Ord PEvent where compare (PEvent i1 _) (PEvent i2 _) = compare i1 i2 -- | The state of a particular baker. -data BakerState = BakerState +data BakerState = forall store. BakerState { _bsIdentity :: !BakerIdentity, _bsInfo :: !FullBakerInfo, - _bsContext :: !(SkovContext BakerConfig), - _bsState :: !(SkovState BakerConfig) + _bsContext :: !(SkovContext store BakerConfig), + _bsState :: !(SkovState store BakerConfig) } -- | Typeclass of a datastructure that collects events.