{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} module Ouroboros.Consensus.Storage.ChainDB.API ( -- * Main ChainDB API ChainDB (..) , getCurrentLedger , getCurrentTip , getHeaderStateHistory , getImmutableLedger , getPastLedger , getTipBlockNo -- * Adding a block , AddBlockPromise (..) , addBlock , addBlockWaitWrittenToDisk , addBlock_ -- * Serialised block/header with its point , WithPoint (..) , getPoint , getSerialisedBlockWithPoint , getSerialisedHeaderWithPoint -- * BlockComponent , BlockComponent (..) -- * Support for tests , fromChain , toChain -- * Iterator API , Iterator (..) , IteratorResult (..) , StreamFrom (..) , StreamTo (..) , UnknownRange (..) , emptyIterator , streamAll , streamFrom , traverseIterator , validBounds -- * Invalid block reason , InvalidBlockReason (..) -- * Followers , ChainType (..) , Follower (..) , traverseFollower -- * Recovery , ChainDbFailure (..) , IsEBB (..) -- * Exceptions , ChainDbError (..) ) where import Control.Monad (void) import Data.Typeable (Typeable) import GHC.Generics (Generic) import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.Block (ChainUpdate, MaxSlotNo, Serialised (..)) import qualified Ouroboros.Network.Block as Network import Ouroboros.Consensus.Block import Ouroboros.Consensus.HeaderStateHistory (HeaderStateHistory (..)) import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Util ((..:)) import Ouroboros.Consensus.Util.CallStack import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.ResourceRegistry import Ouroboros.Consensus.Util.STM (WithFingerprint) import Ouroboros.Consensus.Storage.ChainDB.API.Types.InvalidBlockPunishment (InvalidBlockPunishment) import qualified Ouroboros.Consensus.Storage.ChainDB.API.Types.InvalidBlockPunishment as InvalidBlockPunishment import Ouroboros.Consensus.Storage.Common import Ouroboros.Consensus.Storage.FS.API.Types (FsError) import Ouroboros.Consensus.Storage.LedgerDB.InMemory (LedgerDB) import qualified Ouroboros.Consensus.Storage.LedgerDB.InMemory as LedgerDB import Ouroboros.Consensus.Storage.Serialisation -- Support for tests import Ouroboros.Network.MockChain.Chain (Chain (..)) import qualified Ouroboros.Network.MockChain.Chain as Chain -- | The chain database -- -- The chain database provides a unified interface on top of: -- -- * The ImmutableDB, storing the part of the chain that can't roll back. -- * The VolatileDB, storing the blocks near the tip of the chain, possibly in -- multiple competing forks. -- * The LedgerDB, storing snapshots of the ledger state for blocks in the -- ImmutableDB (and in-memory snapshots for the rest). -- -- In addition to providing a unifying interface on top of these disparate -- components, the main responsibilities that the ChainDB itself has are: -- -- * Chain selection (on initialization and whenever a block is added) -- * Trigger full recovery whenever we detect disk failure in any component -- * Provide iterators across fixed fragments of the current chain -- * Provide followers that track the status of the current chain -- -- The ChainDB instantiates all the various type parameters of these databases -- to conform to the unified interface we provide here. data ChainDB m blk = ChainDB { -- | Add a block to the heap of blocks -- -- We do /not/ assume that the block is valid (under the legder rules); -- it is the responsibility of the Chain DB itself to only select chains -- that are valid. -- -- Conversely, the caller cannot assume that the new block will be added -- to the current chain; even if the block is valid, it will not become -- part of the chain if there are other chains available that are -- preferred by the consensus algorithm (typically, longer chains). -- -- This function typically returns immediately, yielding a -- 'AddBlockPromise' which can be used to wait for the result. You can -- use 'addBlock' to add the block synchronously. -- -- NOTE: back pressure can be applied when overloaded. ChainDB m blk -> InvalidBlockPunishment m -> blk -> m (AddBlockPromise m blk) addBlockAsync :: InvalidBlockPunishment m -> blk -> m (AddBlockPromise m blk) -- | Get the current chain fragment -- -- Suppose the current chain is -- -- > a -> b -> c -> d -> e -> f -- -- and suppose @k = 2@; this means that the most distant fork we can -- switch to is something like -- -- > a -> b -> c -> d -> e' -> f' -- -- The fragment we return will be @[e, f]@, anchored at @d@. In other -- words, the length of the fragment will under normal circumstances -- be exactly @k@ blocks long. It may be shorter if -- -- * We are near genesis -- The anchor will be the genesis point -- (which does not correspond to an actual block) -- -- * The volatile DB suffered some data loss -- Typically (but not necessarily) the volatile DB will not be empty -- and the anchor will be pointing to the tip of the immutable DB. -- -- POSTCONDITION: The Chain DB will be able to switch to any fork starting -- from the anchor of the returned fragment or any subsequent block -- (provided the new fork is at least of the same length as the old). -- -- NOTE: A direct consequence of this guarantee is that the anchor of the -- fragment will move as the chain grows. , ChainDB m blk -> STM m (AnchoredFragment (Header blk)) getCurrentChain :: STM m (AnchoredFragment (Header blk)) -- | Return the LedgerDB containing the last @k@ ledger states. , ChainDB m blk -> STM m (LedgerDB (ExtLedgerState blk)) getLedgerDB :: STM m (LedgerDB (ExtLedgerState blk)) -- | Get block at the tip of the chain, if one exists -- -- Returns 'Nothing' if the database is empty. , ChainDB m blk -> m (Maybe blk) getTipBlock :: m (Maybe blk) -- | Get header at the tip of the chain -- -- NOTE: Calling 'getTipHeader' is cheaper than 'getTipBlock' and then -- extracting the header: most of the time the header at the tip is -- actually in memory, whereas the block never is. -- -- Returns 'Nothing' if the database is empty. , ChainDB m blk -> m (Maybe (Header blk)) getTipHeader :: m (Maybe (Header blk)) -- | Get point of the tip of the chain -- -- Will return 'genesisPoint' if the database is empty; if the -- current chain fragment is empty due to data loss in the volatile DB, -- 'getTipPoint' will return the tip of the immutable DB. , ChainDB m blk -> STM m (Point blk) getTipPoint :: STM m (Point blk) -- | Get the given component(s) of the block at the specified point. If -- there is no block at the given point, 'Nothing' is returned. , ChainDB m blk -> forall b. BlockComponent blk b -> RealPoint blk -> m (Maybe b) getBlockComponent :: forall b. BlockComponent blk b -> RealPoint blk -> m (Maybe b) -- | Return membership check function for recent blocks -- -- This check is only reliable for blocks up to @k@ away from the tip. -- For blocks older than that the results should be regarded as -- non-deterministic. , ChainDB m blk -> STM m (Point blk -> Bool) getIsFetched :: STM m (Point blk -> Bool) -- | Return a function that tells whether a block is known to be valid -- or invalid. -- -- The function will return: -- -- * @Just True@: for blocks in the volatile DB that have been validated -- and were found to be valid. All blocks in the current chain -- fragment (i.e., 'getCurrentChain') are valid. -- -- * @Just False@: for blocks in the volatile DB that have been -- validated and were found to be invalid. -- -- * @Nothing@: for blocks not or no longer in the volatile DB, whether -- they are valid or not, including blocks in the immutable DB. Also -- for blocks in the volatile DB that haven't been validated (yet), -- e.g., because they are disconnected from the current chain or they -- are part of a shorter fork. , ChainDB m blk -> STM m (RealPoint blk -> Maybe Bool) getIsValid :: STM m (RealPoint blk -> Maybe Bool) -- | Get the highest slot number stored in the ChainDB. -- -- Note that the corresponding block doesn't have to be part of the -- current chain, it could be part of some fork, or even be a -- disconnected block. , ChainDB m blk -> STM m MaxSlotNo getMaxSlotNo :: STM m MaxSlotNo -- | Stream blocks -- -- Streaming is not restricted to the current fork, but there must be an -- unbroken path from the starting point to the end point /at the time -- of initialization/ of the iterator. Once the iterator has been -- initialized, it will not be affected by subsequent calls to -- 'addBlock'. To track the current chain, use a 'Follower' instead. -- -- Streaming blocks older than @k@ is permitted, but only when they are -- part of the current fork (at the time of initialization). Streaming a -- fork that forks off more than @k@ blocks in the past is not permitted -- and an 'UnknownRange' error will be returned in that case. -- -- The iterator /does/ have a limited lifetime, however. The chain DB -- internally partitions the chain into an " immutable " part and a -- " volatile " part, moving blocks from the volatile DB to the immutable -- DB when they become more than @k@ deep into the chain. When a block -- with slot number @n@ is added to the immutble DB, a time delay @t@ -- kicks in; after that time delay expires, all blocks older than @n@ may -- be removed from the volatile DB, /including any blocks that happen to -- live on other forks/ (since those forks must now, by definition, be too -- distant). This time delay @t@ also provides a worst-case bound for the -- lifetime of the iterator: if the iterator traverses a chain that -- forks off from our current chain at the tip of the immutable DB, -- then the first block on that fork will become unavailable as soon as -- another block is pushed to the current chain and the subsequent -- time delay expires. -- -- Note: although blocks are moved from the volatile DB to the immutable -- DB after they have become @k@ deep into the chain, due to data -- corruption the suffix of the chain in the volatile DB might be -- shorter than @k@. The immutable DB /always/ determines the maximum -- rollback, which may therefore be shorter than @k@ under such -- circumstances. In addition, streaming blocks which aren't on the -- current fork is permitted, but the oldest volatile block must fit on -- to the tip of the immutable DB. -- -- When the given bounds are nonsensical, an 'InvalidIteratorRange' is -- thrown. -- -- When the given bounds are not part of the chain DB, an 'UnknownRange' -- error is returned. -- -- To stream all blocks from the current chain, use 'streamAll', as it -- correctly handles an empty ChainDB. , ChainDB m blk -> forall b. ResourceRegistry m -> BlockComponent blk b -> StreamFrom blk -> StreamTo blk -> m (Either (UnknownRange blk) (Iterator m blk b)) stream :: forall b. ResourceRegistry m -> BlockComponent blk b -> StreamFrom blk -> StreamTo blk -> m (Either (UnknownRange blk) (Iterator m blk b)) -- | Chain follower -- -- A chain follower is an iterator that tracks the state of the /current/ -- chain: calling @next@ on the iterator will either give you the next -- block header, or (if we have switched to a fork) the instruction to -- rollback. -- -- The tracking iterator starts at genesis (see also 'trackForward'). -- -- This is intended for use by chain consumers to /reliably/ follow a -- chain, desipite the chain being volatile. -- -- Examples of users: -- * The server side of the chain sync mini-protocol for the -- node-to-node protocol using headers and the block size. -- * The server side of the chain sync mini-protocol for the -- node-to-client protocol using blocks. -- , ChainDB m blk -> forall b. ResourceRegistry m -> ChainType -> BlockComponent blk b -> m (Follower m blk b) newFollower :: forall b. ResourceRegistry m -> ChainType -> BlockComponent blk b -> m (Follower m blk b) -- | Function to check whether a block is known to be invalid. -- -- Blocks unknown to the ChainDB will result in 'False'. -- -- If the hash corresponds to a block that is known to be invalid, but -- is now older than 'k', this function may return 'False'. -- -- Whenever a new invalid block is added, the 'Fingerprint' will be -- changed. This is useful when \"watching\" this function in a -- transaction. -- -- Note that when invalid blocks are garbage collected and thus no -- longer detected by this function, the 'Fingerprint' doesn't have to -- change, since the function will not detect new invalid blocks. -- -- It might seem natural to have this function also return whether the -- ChainDB knows that a block is valid, thereby subsuming the 'getIsValid' -- function and simplifying the API. However, this adds the overhead of -- checking whether the block is valid for blocks that are not known to be -- invalid that does not give useful information to current clients -- (ChainSync), since they are only interested in whether a block is known -- to be invalid. The extra information of whether a block is valid is -- only used for testing. -- -- In particular, this affects the watcher in 'bracketChainSyncClient', -- which rechecks the blocks in all candidate chains whenever a new -- invalid block is detected. These blocks are likely to be valid. , ChainDB m blk -> STM m (WithFingerprint (HeaderHash blk -> Maybe (InvalidBlockReason blk))) getIsInvalidBlock :: STM m (WithFingerprint (HeaderHash blk -> Maybe (InvalidBlockReason blk))) -- | Close the ChainDB -- -- Idempotent. -- -- Should only be called on shutdown. , ChainDB m blk -> m () closeDB :: m () -- | Return 'True' when the database is open. -- -- 'False' when the database is closed. , ChainDB m blk -> STM m Bool isOpen :: STM m Bool } getCurrentTip :: (Monad (STM m), HasHeader (Header blk)) => ChainDB m blk -> STM m (Network.Tip blk) getCurrentTip :: ChainDB m blk -> STM m (Tip blk) getCurrentTip = (AnchoredSeq (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk) -> Tip blk) -> STM m (AnchoredSeq (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)) -> STM m (Tip blk) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (Anchor (Header blk) -> Tip blk forall a b. (HeaderHash a ~ HeaderHash b) => Anchor a -> Tip b AF.anchorToTip (Anchor (Header blk) -> Tip blk) -> (AnchoredSeq (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk) -> Anchor (Header blk)) -> AnchoredSeq (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk) -> Tip blk forall b c a. (b -> c) -> (a -> b) -> a -> c . AnchoredSeq (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk) -> Anchor (Header blk) forall v a b. Anchorable v a b => AnchoredSeq v a b -> a AF.headAnchor) (STM m (AnchoredSeq (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)) -> STM m (Tip blk)) -> (ChainDB m blk -> STM m (AnchoredSeq (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk))) -> ChainDB m blk -> STM m (Tip blk) forall b c a. (b -> c) -> (a -> b) -> a -> c . ChainDB m blk -> STM m (AnchoredSeq (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)) forall (m :: * -> *) blk. ChainDB m blk -> STM m (AnchoredFragment (Header blk)) getCurrentChain getTipBlockNo :: (Monad (STM m), HasHeader (Header blk)) => ChainDB m blk -> STM m (WithOrigin BlockNo) getTipBlockNo :: ChainDB m blk -> STM m (WithOrigin BlockNo) getTipBlockNo = (Tip blk -> WithOrigin BlockNo) -> STM m (Tip blk) -> STM m (WithOrigin BlockNo) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap Tip blk -> WithOrigin BlockNo forall b. Tip b -> WithOrigin BlockNo Network.getTipBlockNo (STM m (Tip blk) -> STM m (WithOrigin BlockNo)) -> (ChainDB m blk -> STM m (Tip blk)) -> ChainDB m blk -> STM m (WithOrigin BlockNo) forall b c a. (b -> c) -> (a -> b) -> a -> c . ChainDB m blk -> STM m (Tip blk) forall (m :: * -> *) blk. (Monad (STM m), HasHeader (Header blk)) => ChainDB m blk -> STM m (Tip blk) getCurrentTip -- | Get current ledger getCurrentLedger :: (Monad (STM m), IsLedger (LedgerState blk)) => ChainDB m blk -> STM m (ExtLedgerState blk) getCurrentLedger :: ChainDB m blk -> STM m (ExtLedgerState blk) getCurrentLedger = (LedgerDB (ExtLedgerState blk) -> ExtLedgerState blk) -> STM m (LedgerDB (ExtLedgerState blk)) -> STM m (ExtLedgerState blk) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap LedgerDB (ExtLedgerState blk) -> ExtLedgerState blk forall l. GetTip l => LedgerDB l -> l LedgerDB.ledgerDbCurrent (STM m (LedgerDB (ExtLedgerState blk)) -> STM m (ExtLedgerState blk)) -> (ChainDB m blk -> STM m (LedgerDB (ExtLedgerState blk))) -> ChainDB m blk -> STM m (ExtLedgerState blk) forall b c a. (b -> c) -> (a -> b) -> a -> c . ChainDB m blk -> STM m (LedgerDB (ExtLedgerState blk)) forall (m :: * -> *) blk. ChainDB m blk -> STM m (LedgerDB (ExtLedgerState blk)) getLedgerDB -- | Get the immutable ledger, i.e., typically @k@ blocks back. getImmutableLedger :: Monad (STM m) => ChainDB m blk -> STM m (ExtLedgerState blk) getImmutableLedger :: ChainDB m blk -> STM m (ExtLedgerState blk) getImmutableLedger = (LedgerDB (ExtLedgerState blk) -> ExtLedgerState blk) -> STM m (LedgerDB (ExtLedgerState blk)) -> STM m (ExtLedgerState blk) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap LedgerDB (ExtLedgerState blk) -> ExtLedgerState blk forall l. LedgerDB l -> l LedgerDB.ledgerDbAnchor (STM m (LedgerDB (ExtLedgerState blk)) -> STM m (ExtLedgerState blk)) -> (ChainDB m blk -> STM m (LedgerDB (ExtLedgerState blk))) -> ChainDB m blk -> STM m (ExtLedgerState blk) forall b c a. (b -> c) -> (a -> b) -> a -> c . ChainDB m blk -> STM m (LedgerDB (ExtLedgerState blk)) forall (m :: * -> *) blk. ChainDB m blk -> STM m (LedgerDB (ExtLedgerState blk)) getLedgerDB -- | Get the ledger for the given point. -- -- When the given point is not among the last @k@ blocks of the current -- chain (i.e., older than @k@ or not on the current chain), 'Nothing' is -- returned. getPastLedger :: (Monad (STM m), LedgerSupportsProtocol blk) => ChainDB m blk -> Point blk -> STM m (Maybe (ExtLedgerState blk)) getPastLedger :: ChainDB m blk -> Point blk -> STM m (Maybe (ExtLedgerState blk)) getPastLedger ChainDB m blk db Point blk pt = Point blk -> LedgerDB (ExtLedgerState blk) -> Maybe (ExtLedgerState blk) forall blk l. (HasHeader blk, IsLedger l, HeaderHash l ~ HeaderHash blk) => Point blk -> LedgerDB l -> Maybe l LedgerDB.ledgerDbPast Point blk pt (LedgerDB (ExtLedgerState blk) -> Maybe (ExtLedgerState blk)) -> STM m (LedgerDB (ExtLedgerState blk)) -> STM m (Maybe (ExtLedgerState blk)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> ChainDB m blk -> STM m (LedgerDB (ExtLedgerState blk)) forall (m :: * -> *) blk. ChainDB m blk -> STM m (LedgerDB (ExtLedgerState blk)) getLedgerDB ChainDB m blk db -- | Get a 'HeaderStateHistory' populated with the 'HeaderState's of the -- last @k@ blocks of the current chain. getHeaderStateHistory :: Monad (STM m) => ChainDB m blk -> STM m (HeaderStateHistory blk) getHeaderStateHistory :: ChainDB m blk -> STM m (HeaderStateHistory blk) getHeaderStateHistory = (LedgerDB (ExtLedgerState blk) -> HeaderStateHistory blk) -> STM m (LedgerDB (ExtLedgerState blk)) -> STM m (HeaderStateHistory blk) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap LedgerDB (ExtLedgerState blk) -> HeaderStateHistory blk forall blk. LedgerDB (ExtLedgerState blk) -> HeaderStateHistory blk toHeaderStateHistory (STM m (LedgerDB (ExtLedgerState blk)) -> STM m (HeaderStateHistory blk)) -> (ChainDB m blk -> STM m (LedgerDB (ExtLedgerState blk))) -> ChainDB m blk -> STM m (HeaderStateHistory blk) forall b c a. (b -> c) -> (a -> b) -> a -> c . ChainDB m blk -> STM m (LedgerDB (ExtLedgerState blk)) forall (m :: * -> *) blk. ChainDB m blk -> STM m (LedgerDB (ExtLedgerState blk)) getLedgerDB where toHeaderStateHistory :: LedgerDB (ExtLedgerState blk) -> HeaderStateHistory blk toHeaderStateHistory :: LedgerDB (ExtLedgerState blk) -> HeaderStateHistory blk toHeaderStateHistory = AnchoredSeq (WithOrigin SlotNo) (HeaderState blk) (HeaderState blk) -> HeaderStateHistory blk forall blk. AnchoredSeq (WithOrigin SlotNo) (HeaderState blk) (HeaderState blk) -> HeaderStateHistory blk HeaderStateHistory (AnchoredSeq (WithOrigin SlotNo) (HeaderState blk) (HeaderState blk) -> HeaderStateHistory blk) -> (LedgerDB (ExtLedgerState blk) -> AnchoredSeq (WithOrigin SlotNo) (HeaderState blk) (HeaderState blk)) -> LedgerDB (ExtLedgerState blk) -> HeaderStateHistory blk forall b c a. (b -> c) -> (a -> b) -> a -> c . (ExtLedgerState blk -> HeaderState blk) -> (ExtLedgerState blk -> HeaderState blk) -> LedgerDB (ExtLedgerState blk) -> AnchoredSeq (WithOrigin SlotNo) (HeaderState blk) (HeaderState blk) forall a b l. Anchorable (WithOrigin SlotNo) a b => (l -> a) -> (l -> b) -> LedgerDB l -> AnchoredSeq (WithOrigin SlotNo) a b LedgerDB.ledgerDbBimap ExtLedgerState blk -> HeaderState blk forall blk. ExtLedgerState blk -> HeaderState blk headerState ExtLedgerState blk -> HeaderState blk forall blk. ExtLedgerState blk -> HeaderState blk headerState {------------------------------------------------------------------------------- Adding a block -------------------------------------------------------------------------------} data AddBlockPromise m blk = AddBlockPromise { AddBlockPromise m blk -> STM m Bool blockWrittenToDisk :: STM m Bool -- ^ Use this 'STM' transaction to wait until the block has been written -- to disk. -- -- Returns 'True' when the block was written to disk or 'False' when it -- was ignored, e.g., because it was older than @k@. -- -- If the 'STM' transaction has returned 'True' then 'getIsFetched' will -- return 'True' for the added block. -- -- NOTE: Even when the result is 'False', 'getIsFetched' might still -- return 'True', e.g., the block was older than @k@, but it has been -- downloaded and stored on disk before. , AddBlockPromise m blk -> STM m (Point blk) blockProcessed :: STM m (Point blk) -- ^ Use this 'STM' transaction to wait until the block has been -- processed: the block has been written to disk and chain selection has -- been performed for the block, /unless/ the block is from the future. -- -- The ChainDB's tip after chain selection is returned. When this tip -- doesn't match the added block, it doesn't necessarily mean the block -- wasn't adopted. We might have adopted a longer chain of which the -- added block is a part, but not the tip. -- -- NOTE: When the block is from the future, chain selection for the -- block won't be performed until the block is no longer in the future, -- which might take some time. For that reason, this transaction will -- not wait for chain selection of a block from the future. It will -- return the current tip of the ChainDB after writing the block to -- disk. } -- | Add a block synchronously: wait until the block has been written to disk -- (see 'blockWrittenToDisk'). addBlockWaitWrittenToDisk :: IOLike m => ChainDB m blk -> InvalidBlockPunishment m -> blk -> m Bool addBlockWaitWrittenToDisk :: ChainDB m blk -> InvalidBlockPunishment m -> blk -> m Bool addBlockWaitWrittenToDisk ChainDB m blk chainDB InvalidBlockPunishment m punish blk blk = do AddBlockPromise m blk promise <- ChainDB m blk -> InvalidBlockPunishment m -> blk -> m (AddBlockPromise m blk) forall (m :: * -> *) blk. ChainDB m blk -> InvalidBlockPunishment m -> blk -> m (AddBlockPromise m blk) addBlockAsync ChainDB m blk chainDB InvalidBlockPunishment m punish blk blk STM m Bool -> m Bool forall (m :: * -> *) a. (MonadSTM m, HasCallStack) => STM m a -> m a atomically (STM m Bool -> m Bool) -> STM m Bool -> m Bool forall a b. (a -> b) -> a -> b $ AddBlockPromise m blk -> STM m Bool forall (m :: * -> *) blk. AddBlockPromise m blk -> STM m Bool blockWrittenToDisk AddBlockPromise m blk promise -- | Add a block synchronously: wait until the block has been processed (see -- 'blockProcessed'). The new tip of the ChainDB is returned. addBlock :: IOLike m => ChainDB m blk -> InvalidBlockPunishment m -> blk -> m (Point blk) addBlock :: ChainDB m blk -> InvalidBlockPunishment m -> blk -> m (Point blk) addBlock ChainDB m blk chainDB InvalidBlockPunishment m punish blk blk = do AddBlockPromise m blk promise <- ChainDB m blk -> InvalidBlockPunishment m -> blk -> m (AddBlockPromise m blk) forall (m :: * -> *) blk. ChainDB m blk -> InvalidBlockPunishment m -> blk -> m (AddBlockPromise m blk) addBlockAsync ChainDB m blk chainDB InvalidBlockPunishment m punish blk blk STM m (Point blk) -> m (Point blk) forall (m :: * -> *) a. (MonadSTM m, HasCallStack) => STM m a -> m a atomically (STM m (Point blk) -> m (Point blk)) -> STM m (Point blk) -> m (Point blk) forall a b. (a -> b) -> a -> b $ AddBlockPromise m blk -> STM m (Point blk) forall (m :: * -> *) blk. AddBlockPromise m blk -> STM m (Point blk) blockProcessed AddBlockPromise m blk promise -- | Add a block synchronously. Variant of 'addBlock' that doesn't return the -- new tip of the ChainDB. addBlock_ :: IOLike m => ChainDB m blk -> InvalidBlockPunishment m -> blk -> m () addBlock_ :: ChainDB m blk -> InvalidBlockPunishment m -> blk -> m () addBlock_ = m (Point blk) -> m () forall (f :: * -> *) a. Functor f => f a -> f () void (m (Point blk) -> m ()) -> (ChainDB m blk -> InvalidBlockPunishment m -> blk -> m (Point blk)) -> ChainDB m blk -> InvalidBlockPunishment m -> blk -> m () forall y z x0 x1 x2. (y -> z) -> (x0 -> x1 -> x2 -> y) -> x0 -> x1 -> x2 -> z ..: ChainDB m blk -> InvalidBlockPunishment m -> blk -> m (Point blk) forall (m :: * -> *) blk. IOLike m => ChainDB m blk -> InvalidBlockPunishment m -> blk -> m (Point blk) addBlock {------------------------------------------------------------------------------- Serialised block/header with its point -------------------------------------------------------------------------------} -- | A @b@ together with its 'Point'. -- -- The 'Point' is needed because we often need to know the hash, slot, or -- point itself of the block or header in question, and we don't want to -- deserialise the block to obtain it. data WithPoint blk b = WithPoint { WithPoint blk b -> b withoutPoint :: !b , WithPoint blk b -> Point blk point :: !(Point blk) } type instance HeaderHash (WithPoint blk b) = HeaderHash blk instance StandardHash blk => StandardHash (WithPoint blk b) getPoint :: BlockComponent blk (Point blk) getPoint :: BlockComponent blk (Point blk) getPoint = SlotNo -> HeaderHash blk -> Point blk forall block. SlotNo -> HeaderHash block -> Point block BlockPoint (SlotNo -> HeaderHash blk -> Point blk) -> BlockComponent blk SlotNo -> BlockComponent blk (HeaderHash blk -> Point blk) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> BlockComponent blk SlotNo forall blk. BlockComponent blk SlotNo GetSlot BlockComponent blk (HeaderHash blk -> Point blk) -> BlockComponent blk (HeaderHash blk) -> BlockComponent blk (Point blk) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> BlockComponent blk (HeaderHash blk) forall blk. BlockComponent blk (HeaderHash blk) GetHash getSerialisedBlockWithPoint :: BlockComponent blk (WithPoint blk (Serialised blk)) getSerialisedBlockWithPoint :: BlockComponent blk (WithPoint blk (Serialised blk)) getSerialisedBlockWithPoint = Serialised blk -> Point blk -> WithPoint blk (Serialised blk) forall blk b. b -> Point blk -> WithPoint blk b WithPoint (Serialised blk -> Point blk -> WithPoint blk (Serialised blk)) -> BlockComponent blk (Serialised blk) -> BlockComponent blk (Point blk -> WithPoint blk (Serialised blk)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> (ByteString -> Serialised blk forall a. ByteString -> Serialised a Serialised (ByteString -> Serialised blk) -> BlockComponent blk ByteString -> BlockComponent blk (Serialised blk) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> BlockComponent blk ByteString forall blk. BlockComponent blk ByteString GetRawBlock) BlockComponent blk (Point blk -> WithPoint blk (Serialised blk)) -> BlockComponent blk (Point blk) -> BlockComponent blk (WithPoint blk (Serialised blk)) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> BlockComponent blk (Point blk) forall blk. BlockComponent blk (Point blk) getPoint getSerialisedHeader :: BlockComponent blk (SerialisedHeader blk) getSerialisedHeader :: BlockComponent blk (SerialisedHeader blk) getSerialisedHeader = ((SomeSecond (NestedCtxt Header) blk, ByteString) -> SerialisedHeader blk) -> SomeSecond (NestedCtxt Header) blk -> ByteString -> SerialisedHeader blk forall a b c. ((a, b) -> c) -> a -> b -> c curry (SomeSecond (NestedCtxt Header) blk, ByteString) -> SerialisedHeader blk forall blk. (SomeSecond (NestedCtxt Header) blk, ByteString) -> SerialisedHeader blk serialisedHeaderFromPair (SomeSecond (NestedCtxt Header) blk -> ByteString -> SerialisedHeader blk) -> BlockComponent blk (SomeSecond (NestedCtxt Header) blk) -> BlockComponent blk (ByteString -> SerialisedHeader blk) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> BlockComponent blk (SomeSecond (NestedCtxt Header) blk) forall blk. BlockComponent blk (SomeSecond (NestedCtxt Header) blk) GetNestedCtxt BlockComponent blk (ByteString -> SerialisedHeader blk) -> BlockComponent blk ByteString -> BlockComponent blk (SerialisedHeader blk) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> BlockComponent blk ByteString forall blk. BlockComponent blk ByteString GetRawHeader getSerialisedHeaderWithPoint :: BlockComponent blk (WithPoint blk (SerialisedHeader blk)) getSerialisedHeaderWithPoint :: BlockComponent blk (WithPoint blk (SerialisedHeader blk)) getSerialisedHeaderWithPoint = SerialisedHeader blk -> Point blk -> WithPoint blk (SerialisedHeader blk) forall blk b. b -> Point blk -> WithPoint blk b WithPoint (SerialisedHeader blk -> Point blk -> WithPoint blk (SerialisedHeader blk)) -> BlockComponent blk (SerialisedHeader blk) -> BlockComponent blk (Point blk -> WithPoint blk (SerialisedHeader blk)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> BlockComponent blk (SerialisedHeader blk) forall blk. BlockComponent blk (SerialisedHeader blk) getSerialisedHeader BlockComponent blk (Point blk -> WithPoint blk (SerialisedHeader blk)) -> BlockComponent blk (Point blk) -> BlockComponent blk (WithPoint blk (SerialisedHeader blk)) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> BlockComponent blk (Point blk) forall blk. BlockComponent blk (Point blk) getPoint {------------------------------------------------------------------------------- Support for tests -------------------------------------------------------------------------------} toChain :: forall m blk. (HasCallStack, IOLike m, HasHeader blk) => ChainDB m blk -> m (Chain blk) toChain :: ChainDB m blk -> m (Chain blk) toChain ChainDB m blk chainDB = (ResourceRegistry m -> m (Chain blk)) -> m (Chain blk) forall (m :: * -> *) a. (IOLike m, HasCallStack) => (ResourceRegistry m -> m a) -> m a withRegistry ((ResourceRegistry m -> m (Chain blk)) -> m (Chain blk)) -> (ResourceRegistry m -> m (Chain blk)) -> m (Chain blk) forall a b. (a -> b) -> a -> b $ \ResourceRegistry m registry -> ChainDB m blk -> ResourceRegistry m -> BlockComponent blk blk -> m (Iterator m blk blk) forall (m :: * -> *) blk b. (MonadSTM m, HasHeader blk, HasCallStack) => ChainDB m blk -> ResourceRegistry m -> BlockComponent blk b -> m (Iterator m blk b) streamAll ChainDB m blk chainDB ResourceRegistry m registry BlockComponent blk blk forall blk. BlockComponent blk blk GetBlock m (Iterator m blk blk) -> (Iterator m blk blk -> m (Chain blk)) -> m (Chain blk) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= Chain blk -> Iterator m blk blk -> m (Chain blk) go Chain blk forall block. Chain block Genesis where go :: Chain blk -> Iterator m blk blk -> m (Chain blk) go :: Chain blk -> Iterator m blk blk -> m (Chain blk) go Chain blk chain Iterator m blk blk it = do IteratorResult blk blk next <- Iterator m blk blk -> m (IteratorResult blk blk) forall (m :: * -> *) blk b. Iterator m blk b -> m (IteratorResult blk b) iteratorNext Iterator m blk blk it case IteratorResult blk blk next of IteratorResult blk blk -> Chain blk -> Iterator m blk blk -> m (Chain blk) go (blk -> Chain blk -> Chain blk forall block. HasHeader block => block -> Chain block -> Chain block Chain.addBlock blk blk Chain blk chain) Iterator m blk blk it IteratorResult blk blk IteratorExhausted -> Chain blk -> m (Chain blk) forall (m :: * -> *) a. Monad m => a -> m a return Chain blk chain IteratorBlockGCed RealPoint blk _ -> [Char] -> m (Chain blk) forall a. HasCallStack => [Char] -> a error [Char] "block on the current chain was garbage-collected" fromChain :: forall m blk. IOLike m => m (ChainDB m blk) -> Chain blk -> m (ChainDB m blk) fromChain :: m (ChainDB m blk) -> Chain blk -> m (ChainDB m blk) fromChain m (ChainDB m blk) openDB Chain blk chain = do ChainDB m blk chainDB <- m (ChainDB m blk) openDB (blk -> m ()) -> [blk] -> m () forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => (a -> m b) -> t a -> m () mapM_ (ChainDB m blk -> InvalidBlockPunishment m -> blk -> m () forall (m :: * -> *) blk. IOLike m => ChainDB m blk -> InvalidBlockPunishment m -> blk -> m () addBlock_ ChainDB m blk chainDB InvalidBlockPunishment m forall (m :: * -> *). Applicative m => InvalidBlockPunishment m InvalidBlockPunishment.noPunishment) ([blk] -> m ()) -> [blk] -> m () forall a b. (a -> b) -> a -> b $ Chain blk -> [blk] forall block. Chain block -> [block] Chain.toOldestFirst Chain blk chain ChainDB m blk -> m (ChainDB m blk) forall (m :: * -> *) a. Monad m => a -> m a return ChainDB m blk chainDB {------------------------------------------------------------------------------- Iterator API -------------------------------------------------------------------------------} data Iterator m blk b = Iterator { Iterator m blk b -> m (IteratorResult blk b) iteratorNext :: m (IteratorResult blk b) , Iterator m blk b -> m () iteratorClose :: m () -- ^ When 'fmap'-ing or 'traverse'-ing (or using 'traverseIterator') an -- 'Iterator', the resulting iterator will still refer to and use the -- original one. This means that when either of them is closed, both -- will be closed in practice. } deriving (a -> Iterator m blk b -> Iterator m blk a (a -> b) -> Iterator m blk a -> Iterator m blk b (forall a b. (a -> b) -> Iterator m blk a -> Iterator m blk b) -> (forall a b. a -> Iterator m blk b -> Iterator m blk a) -> Functor (Iterator m blk) forall a b. a -> Iterator m blk b -> Iterator m blk a forall a b. (a -> b) -> Iterator m blk a -> Iterator m blk b forall (f :: * -> *). (forall a b. (a -> b) -> f a -> f b) -> (forall a b. a -> f b -> f a) -> Functor f forall (m :: * -> *) blk a b. Functor m => a -> Iterator m blk b -> Iterator m blk a forall (m :: * -> *) blk a b. Functor m => (a -> b) -> Iterator m blk a -> Iterator m blk b <$ :: a -> Iterator m blk b -> Iterator m blk a $c<$ :: forall (m :: * -> *) blk a b. Functor m => a -> Iterator m blk b -> Iterator m blk a fmap :: (a -> b) -> Iterator m blk a -> Iterator m blk b $cfmap :: forall (m :: * -> *) blk a b. Functor m => (a -> b) -> Iterator m blk a -> Iterator m blk b Functor, Iterator m blk a -> Bool (a -> m) -> Iterator m blk a -> m (a -> b -> b) -> b -> Iterator m blk a -> b (forall m. Monoid m => Iterator m blk m -> m) -> (forall m a. Monoid m => (a -> m) -> Iterator m blk a -> m) -> (forall m a. Monoid m => (a -> m) -> Iterator m blk a -> m) -> (forall a b. (a -> b -> b) -> b -> Iterator m blk a -> b) -> (forall a b. (a -> b -> b) -> b -> Iterator m blk a -> b) -> (forall b a. (b -> a -> b) -> b -> Iterator m blk a -> b) -> (forall b a. (b -> a -> b) -> b -> Iterator m blk a -> b) -> (forall a. (a -> a -> a) -> Iterator m blk a -> a) -> (forall a. (a -> a -> a) -> Iterator m blk a -> a) -> (forall a. Iterator m blk a -> [a]) -> (forall a. Iterator m blk a -> Bool) -> (forall a. Iterator m blk a -> Int) -> (forall a. Eq a => a -> Iterator m blk a -> Bool) -> (forall a. Ord a => Iterator m blk a -> a) -> (forall a. Ord a => Iterator m blk a -> a) -> (forall a. Num a => Iterator m blk a -> a) -> (forall a. Num a => Iterator m blk a -> a) -> Foldable (Iterator m blk) forall a. Eq a => a -> Iterator m blk a -> Bool forall a. Num a => Iterator m blk a -> a forall a. Ord a => Iterator m blk a -> a forall m. Monoid m => Iterator m blk m -> m forall a. Iterator m blk a -> Bool forall a. Iterator m blk a -> Int forall a. Iterator m blk a -> [a] forall a. (a -> a -> a) -> Iterator m blk a -> a forall m a. Monoid m => (a -> m) -> Iterator m blk a -> m forall b a. (b -> a -> b) -> b -> Iterator m blk a -> b forall a b. (a -> b -> b) -> b -> Iterator m blk a -> b forall (t :: * -> *). (forall m. Monoid m => t m -> m) -> (forall m a. Monoid m => (a -> m) -> t a -> m) -> (forall m a. Monoid m => (a -> m) -> t a -> m) -> (forall a b. (a -> b -> b) -> b -> t a -> b) -> (forall a b. (a -> b -> b) -> b -> t a -> b) -> (forall b a. (b -> a -> b) -> b -> t a -> b) -> (forall b a. (b -> a -> b) -> b -> t a -> b) -> (forall a. (a -> a -> a) -> t a -> a) -> (forall a. (a -> a -> a) -> t a -> a) -> (forall a. t a -> [a]) -> (forall a. t a -> Bool) -> (forall a. t a -> Int) -> (forall a. Eq a => a -> t a -> Bool) -> (forall a. Ord a => t a -> a) -> (forall a. Ord a => t a -> a) -> (forall a. Num a => t a -> a) -> (forall a. Num a => t a -> a) -> Foldable t forall (m :: * -> *) blk a. (Foldable m, Eq a) => a -> Iterator m blk a -> Bool forall (m :: * -> *) blk a. (Foldable m, Num a) => Iterator m blk a -> a forall (m :: * -> *) blk a. (Foldable m, Ord a) => Iterator m blk a -> a forall (m :: * -> *) blk m. (Foldable m, Monoid m) => Iterator m blk m -> m forall (m :: * -> *) blk a. Foldable m => Iterator m blk a -> Bool forall (m :: * -> *) blk a. Foldable m => Iterator m blk a -> Int forall (m :: * -> *) blk a. Foldable m => Iterator m blk a -> [a] forall (m :: * -> *) blk a. Foldable m => (a -> a -> a) -> Iterator m blk a -> a forall (m :: * -> *) blk m a. (Foldable m, Monoid m) => (a -> m) -> Iterator m blk a -> m forall (m :: * -> *) blk b a. Foldable m => (b -> a -> b) -> b -> Iterator m blk a -> b forall (m :: * -> *) blk a b. Foldable m => (a -> b -> b) -> b -> Iterator m blk a -> b product :: Iterator m blk a -> a $cproduct :: forall (m :: * -> *) blk a. (Foldable m, Num a) => Iterator m blk a -> a sum :: Iterator m blk a -> a $csum :: forall (m :: * -> *) blk a. (Foldable m, Num a) => Iterator m blk a -> a minimum :: Iterator m blk a -> a $cminimum :: forall (m :: * -> *) blk a. (Foldable m, Ord a) => Iterator m blk a -> a maximum :: Iterator m blk a -> a $cmaximum :: forall (m :: * -> *) blk a. (Foldable m, Ord a) => Iterator m blk a -> a elem :: a -> Iterator m blk a -> Bool $celem :: forall (m :: * -> *) blk a. (Foldable m, Eq a) => a -> Iterator m blk a -> Bool length :: Iterator m blk a -> Int $clength :: forall (m :: * -> *) blk a. Foldable m => Iterator m blk a -> Int null :: Iterator m blk a -> Bool $cnull :: forall (m :: * -> *) blk a. Foldable m => Iterator m blk a -> Bool toList :: Iterator m blk a -> [a] $ctoList :: forall (m :: * -> *) blk a. Foldable m => Iterator m blk a -> [a] foldl1 :: (a -> a -> a) -> Iterator m blk a -> a $cfoldl1 :: forall (m :: * -> *) blk a. Foldable m => (a -> a -> a) -> Iterator m blk a -> a foldr1 :: (a -> a -> a) -> Iterator m blk a -> a $cfoldr1 :: forall (m :: * -> *) blk a. Foldable m => (a -> a -> a) -> Iterator m blk a -> a foldl' :: (b -> a -> b) -> b -> Iterator m blk a -> b $cfoldl' :: forall (m :: * -> *) blk b a. Foldable m => (b -> a -> b) -> b -> Iterator m blk a -> b foldl :: (b -> a -> b) -> b -> Iterator m blk a -> b $cfoldl :: forall (m :: * -> *) blk b a. Foldable m => (b -> a -> b) -> b -> Iterator m blk a -> b foldr' :: (a -> b -> b) -> b -> Iterator m blk a -> b $cfoldr' :: forall (m :: * -> *) blk a b. Foldable m => (a -> b -> b) -> b -> Iterator m blk a -> b foldr :: (a -> b -> b) -> b -> Iterator m blk a -> b $cfoldr :: forall (m :: * -> *) blk a b. Foldable m => (a -> b -> b) -> b -> Iterator m blk a -> b foldMap' :: (a -> m) -> Iterator m blk a -> m $cfoldMap' :: forall (m :: * -> *) blk m a. (Foldable m, Monoid m) => (a -> m) -> Iterator m blk a -> m foldMap :: (a -> m) -> Iterator m blk a -> m $cfoldMap :: forall (m :: * -> *) blk m a. (Foldable m, Monoid m) => (a -> m) -> Iterator m blk a -> m fold :: Iterator m blk m -> m $cfold :: forall (m :: * -> *) blk m. (Foldable m, Monoid m) => Iterator m blk m -> m Foldable, Functor (Iterator m blk) Foldable (Iterator m blk) Functor (Iterator m blk) -> Foldable (Iterator m blk) -> (forall (f :: * -> *) a b. Applicative f => (a -> f b) -> Iterator m blk a -> f (Iterator m blk b)) -> (forall (f :: * -> *) a. Applicative f => Iterator m blk (f a) -> f (Iterator m blk a)) -> (forall (m :: * -> *) a b. Monad m => (a -> m b) -> Iterator m blk a -> m (Iterator m blk b)) -> (forall (m :: * -> *) a. Monad m => Iterator m blk (m a) -> m (Iterator m blk a)) -> Traversable (Iterator m blk) (a -> f b) -> Iterator m blk a -> f (Iterator m blk b) forall (t :: * -> *). Functor t -> Foldable t -> (forall (f :: * -> *) a b. Applicative f => (a -> f b) -> t a -> f (t b)) -> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a)) -> (forall (m :: * -> *) a b. Monad m => (a -> m b) -> t a -> m (t b)) -> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a)) -> Traversable t forall (m :: * -> *) a. Monad m => Iterator m blk (m a) -> m (Iterator m blk a) forall (f :: * -> *) a. Applicative f => Iterator m blk (f a) -> f (Iterator m blk a) forall (m :: * -> *) blk. Traversable m => Functor (Iterator m blk) forall (m :: * -> *) blk. Traversable m => Foldable (Iterator m blk) forall (m :: * -> *) blk (m :: * -> *) a. (Traversable m, Monad m) => Iterator m blk (m a) -> m (Iterator m blk a) forall (m :: * -> *) blk (f :: * -> *) a. (Traversable m, Applicative f) => Iterator m blk (f a) -> f (Iterator m blk a) forall (m :: * -> *) blk (m :: * -> *) a b. (Traversable m, Monad m) => (a -> m b) -> Iterator m blk a -> m (Iterator m blk b) forall (m :: * -> *) blk (f :: * -> *) a b. (Traversable m, Applicative f) => (a -> f b) -> Iterator m blk a -> f (Iterator m blk b) forall (m :: * -> *) a b. Monad m => (a -> m b) -> Iterator m blk a -> m (Iterator m blk b) forall (f :: * -> *) a b. Applicative f => (a -> f b) -> Iterator m blk a -> f (Iterator m blk b) sequence :: Iterator m blk (m a) -> m (Iterator m blk a) $csequence :: forall (m :: * -> *) blk (m :: * -> *) a. (Traversable m, Monad m) => Iterator m blk (m a) -> m (Iterator m blk a) mapM :: (a -> m b) -> Iterator m blk a -> m (Iterator m blk b) $cmapM :: forall (m :: * -> *) blk (m :: * -> *) a b. (Traversable m, Monad m) => (a -> m b) -> Iterator m blk a -> m (Iterator m blk b) sequenceA :: Iterator m blk (f a) -> f (Iterator m blk a) $csequenceA :: forall (m :: * -> *) blk (f :: * -> *) a. (Traversable m, Applicative f) => Iterator m blk (f a) -> f (Iterator m blk a) traverse :: (a -> f b) -> Iterator m blk a -> f (Iterator m blk b) $ctraverse :: forall (m :: * -> *) blk (f :: * -> *) a b. (Traversable m, Applicative f) => (a -> f b) -> Iterator m blk a -> f (Iterator m blk b) $cp2Traversable :: forall (m :: * -> *) blk. Traversable m => Foldable (Iterator m blk) $cp1Traversable :: forall (m :: * -> *) blk. Traversable m => Functor (Iterator m blk) Traversable) -- | An iterator that is immediately exhausted. emptyIterator :: Monad m => Iterator m blk b emptyIterator :: Iterator m blk b emptyIterator = Iterator :: forall (m :: * -> *) blk b. m (IteratorResult blk b) -> m () -> Iterator m blk b Iterator { iteratorNext :: m (IteratorResult blk b) iteratorNext = IteratorResult blk b -> m (IteratorResult blk b) forall (m :: * -> *) a. Monad m => a -> m a return IteratorResult blk b forall blk b. IteratorResult blk b IteratorExhausted , iteratorClose :: m () iteratorClose = () -> m () forall (m :: * -> *) a. Monad m => a -> m a return () } -- | Variant of 'traverse' instantiated to @'Iterator' m blk@ that executes -- the monadic function when calling 'iteratorNext'. traverseIterator :: Monad m => (b -> m b') -> Iterator m blk b -> Iterator m blk b' traverseIterator :: (b -> m b') -> Iterator m blk b -> Iterator m blk b' traverseIterator b -> m b' f Iterator m blk b it = Iterator m blk b it { iteratorNext :: m (IteratorResult blk b') iteratorNext = Iterator m blk b -> m (IteratorResult blk b) forall (m :: * -> *) blk b. Iterator m blk b -> m (IteratorResult blk b) iteratorNext Iterator m blk b it m (IteratorResult blk b) -> (IteratorResult blk b -> m (IteratorResult blk b')) -> m (IteratorResult blk b') forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= (b -> m b') -> IteratorResult blk b -> m (IteratorResult blk b') forall (t :: * -> *) (f :: * -> *) a b. (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) traverse b -> m b' f } data IteratorResult blk b = IteratorExhausted | IteratorResult b | IteratorBlockGCed (RealPoint blk) -- ^ The block that was supposed to be streamed was garbage-collected from -- the VolatileDB, but not added to the ImmutableDB. -- -- This will only happen when streaming very old forks very slowly. deriving (a -> IteratorResult blk b -> IteratorResult blk a (a -> b) -> IteratorResult blk a -> IteratorResult blk b (forall a b. (a -> b) -> IteratorResult blk a -> IteratorResult blk b) -> (forall a b. a -> IteratorResult blk b -> IteratorResult blk a) -> Functor (IteratorResult blk) forall a b. a -> IteratorResult blk b -> IteratorResult blk a forall a b. (a -> b) -> IteratorResult blk a -> IteratorResult blk b forall blk a b. a -> IteratorResult blk b -> IteratorResult blk a forall blk a b. (a -> b) -> IteratorResult blk a -> IteratorResult blk b forall (f :: * -> *). (forall a b. (a -> b) -> f a -> f b) -> (forall a b. a -> f b -> f a) -> Functor f <$ :: a -> IteratorResult blk b -> IteratorResult blk a $c<$ :: forall blk a b. a -> IteratorResult blk b -> IteratorResult blk a fmap :: (a -> b) -> IteratorResult blk a -> IteratorResult blk b $cfmap :: forall blk a b. (a -> b) -> IteratorResult blk a -> IteratorResult blk b Functor, IteratorResult blk a -> Bool (a -> m) -> IteratorResult blk a -> m (a -> b -> b) -> b -> IteratorResult blk a -> b (forall m. Monoid m => IteratorResult blk m -> m) -> (forall m a. Monoid m => (a -> m) -> IteratorResult blk a -> m) -> (forall m a. Monoid m => (a -> m) -> IteratorResult blk a -> m) -> (forall a b. (a -> b -> b) -> b -> IteratorResult blk a -> b) -> (forall a b. (a -> b -> b) -> b -> IteratorResult blk a -> b) -> (forall b a. (b -> a -> b) -> b -> IteratorResult blk a -> b) -> (forall b a. (b -> a -> b) -> b -> IteratorResult blk a -> b) -> (forall a. (a -> a -> a) -> IteratorResult blk a -> a) -> (forall a. (a -> a -> a) -> IteratorResult blk a -> a) -> (forall a. IteratorResult blk a -> [a]) -> (forall a. IteratorResult blk a -> Bool) -> (forall a. IteratorResult blk a -> Int) -> (forall a. Eq a => a -> IteratorResult blk a -> Bool) -> (forall a. Ord a => IteratorResult blk a -> a) -> (forall a. Ord a => IteratorResult blk a -> a) -> (forall a. Num a => IteratorResult blk a -> a) -> (forall a. Num a => IteratorResult blk a -> a) -> Foldable (IteratorResult blk) forall a. Eq a => a -> IteratorResult blk a -> Bool forall a. Num a => IteratorResult blk a -> a forall a. Ord a => IteratorResult blk a -> a forall m. Monoid m => IteratorResult blk m -> m forall a. IteratorResult blk a -> Bool forall a. IteratorResult blk a -> Int forall a. IteratorResult blk a -> [a] forall a. (a -> a -> a) -> IteratorResult blk a -> a forall blk a. Eq a => a -> IteratorResult blk a -> Bool forall blk a. Num a => IteratorResult blk a -> a forall blk a. Ord a => IteratorResult blk a -> a forall m a. Monoid m => (a -> m) -> IteratorResult blk a -> m forall blk m. Monoid m => IteratorResult blk m -> m forall blk a. IteratorResult blk a -> Bool forall blk a. IteratorResult blk a -> Int forall blk a. IteratorResult blk a -> [a] forall b a. (b -> a -> b) -> b -> IteratorResult blk a -> b forall a b. (a -> b -> b) -> b -> IteratorResult blk a -> b forall blk a. (a -> a -> a) -> IteratorResult blk a -> a forall blk m a. Monoid m => (a -> m) -> IteratorResult blk a -> m forall blk b a. (b -> a -> b) -> b -> IteratorResult blk a -> b forall blk a b. (a -> b -> b) -> b -> IteratorResult blk a -> b forall (t :: * -> *). (forall m. Monoid m => t m -> m) -> (forall m a. Monoid m => (a -> m) -> t a -> m) -> (forall m a. Monoid m => (a -> m) -> t a -> m) -> (forall a b. (a -> b -> b) -> b -> t a -> b) -> (forall a b. (a -> b -> b) -> b -> t a -> b) -> (forall b a. (b -> a -> b) -> b -> t a -> b) -> (forall b a. (b -> a -> b) -> b -> t a -> b) -> (forall a. (a -> a -> a) -> t a -> a) -> (forall a. (a -> a -> a) -> t a -> a) -> (forall a. t a -> [a]) -> (forall a. t a -> Bool) -> (forall a. t a -> Int) -> (forall a. Eq a => a -> t a -> Bool) -> (forall a. Ord a => t a -> a) -> (forall a. Ord a => t a -> a) -> (forall a. Num a => t a -> a) -> (forall a. Num a => t a -> a) -> Foldable t product :: IteratorResult blk a -> a $cproduct :: forall blk a. Num a => IteratorResult blk a -> a sum :: IteratorResult blk a -> a $csum :: forall blk a. Num a => IteratorResult blk a -> a minimum :: IteratorResult blk a -> a $cminimum :: forall blk a. Ord a => IteratorResult blk a -> a maximum :: IteratorResult blk a -> a $cmaximum :: forall blk a. Ord a => IteratorResult blk a -> a elem :: a -> IteratorResult blk a -> Bool $celem :: forall blk a. Eq a => a -> IteratorResult blk a -> Bool length :: IteratorResult blk a -> Int $clength :: forall blk a. IteratorResult blk a -> Int null :: IteratorResult blk a -> Bool $cnull :: forall blk a. IteratorResult blk a -> Bool toList :: IteratorResult blk a -> [a] $ctoList :: forall blk a. IteratorResult blk a -> [a] foldl1 :: (a -> a -> a) -> IteratorResult blk a -> a $cfoldl1 :: forall blk a. (a -> a -> a) -> IteratorResult blk a -> a foldr1 :: (a -> a -> a) -> IteratorResult blk a -> a $cfoldr1 :: forall blk a. (a -> a -> a) -> IteratorResult blk a -> a foldl' :: (b -> a -> b) -> b -> IteratorResult blk a -> b $cfoldl' :: forall blk b a. (b -> a -> b) -> b -> IteratorResult blk a -> b foldl :: (b -> a -> b) -> b -> IteratorResult blk a -> b $cfoldl :: forall blk b a. (b -> a -> b) -> b -> IteratorResult blk a -> b foldr' :: (a -> b -> b) -> b -> IteratorResult blk a -> b $cfoldr' :: forall blk a b. (a -> b -> b) -> b -> IteratorResult blk a -> b foldr :: (a -> b -> b) -> b -> IteratorResult blk a -> b $cfoldr :: forall blk a b. (a -> b -> b) -> b -> IteratorResult blk a -> b foldMap' :: (a -> m) -> IteratorResult blk a -> m $cfoldMap' :: forall blk m a. Monoid m => (a -> m) -> IteratorResult blk a -> m foldMap :: (a -> m) -> IteratorResult blk a -> m $cfoldMap :: forall blk m a. Monoid m => (a -> m) -> IteratorResult blk a -> m fold :: IteratorResult blk m -> m $cfold :: forall blk m. Monoid m => IteratorResult blk m -> m Foldable, Functor (IteratorResult blk) Foldable (IteratorResult blk) Functor (IteratorResult blk) -> Foldable (IteratorResult blk) -> (forall (f :: * -> *) a b. Applicative f => (a -> f b) -> IteratorResult blk a -> f (IteratorResult blk b)) -> (forall (f :: * -> *) a. Applicative f => IteratorResult blk (f a) -> f (IteratorResult blk a)) -> (forall (m :: * -> *) a b. Monad m => (a -> m b) -> IteratorResult blk a -> m (IteratorResult blk b)) -> (forall (m :: * -> *) a. Monad m => IteratorResult blk (m a) -> m (IteratorResult blk a)) -> Traversable (IteratorResult blk) (a -> f b) -> IteratorResult blk a -> f (IteratorResult blk b) forall blk. Functor (IteratorResult blk) forall blk. Foldable (IteratorResult blk) forall blk (m :: * -> *) a. Monad m => IteratorResult blk (m a) -> m (IteratorResult blk a) forall blk (f :: * -> *) a. Applicative f => IteratorResult blk (f a) -> f (IteratorResult blk a) forall blk (m :: * -> *) a b. Monad m => (a -> m b) -> IteratorResult blk a -> m (IteratorResult blk b) forall blk (f :: * -> *) a b. Applicative f => (a -> f b) -> IteratorResult blk a -> f (IteratorResult blk b) forall (t :: * -> *). Functor t -> Foldable t -> (forall (f :: * -> *) a b. Applicative f => (a -> f b) -> t a -> f (t b)) -> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a)) -> (forall (m :: * -> *) a b. Monad m => (a -> m b) -> t a -> m (t b)) -> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a)) -> Traversable t forall (m :: * -> *) a. Monad m => IteratorResult blk (m a) -> m (IteratorResult blk a) forall (f :: * -> *) a. Applicative f => IteratorResult blk (f a) -> f (IteratorResult blk a) forall (m :: * -> *) a b. Monad m => (a -> m b) -> IteratorResult blk a -> m (IteratorResult blk b) forall (f :: * -> *) a b. Applicative f => (a -> f b) -> IteratorResult blk a -> f (IteratorResult blk b) sequence :: IteratorResult blk (m a) -> m (IteratorResult blk a) $csequence :: forall blk (m :: * -> *) a. Monad m => IteratorResult blk (m a) -> m (IteratorResult blk a) mapM :: (a -> m b) -> IteratorResult blk a -> m (IteratorResult blk b) $cmapM :: forall blk (m :: * -> *) a b. Monad m => (a -> m b) -> IteratorResult blk a -> m (IteratorResult blk b) sequenceA :: IteratorResult blk (f a) -> f (IteratorResult blk a) $csequenceA :: forall blk (f :: * -> *) a. Applicative f => IteratorResult blk (f a) -> f (IteratorResult blk a) traverse :: (a -> f b) -> IteratorResult blk a -> f (IteratorResult blk b) $ctraverse :: forall blk (f :: * -> *) a b. Applicative f => (a -> f b) -> IteratorResult blk a -> f (IteratorResult blk b) $cp2Traversable :: forall blk. Foldable (IteratorResult blk) $cp1Traversable :: forall blk. Functor (IteratorResult blk) Traversable) deriving instance (Eq blk, Eq b, StandardHash blk) => Eq (IteratorResult blk b) deriving instance (Show blk, Show b, StandardHash blk) => Show (IteratorResult blk b) data UnknownRange blk = -- | The block at the given point was not found in the ChainDB. MissingBlock (RealPoint blk) -- | The requested range forks off too far in the past, i.e. it doesn't -- fit on the tip of the ImmutableDB. | ForkTooOld (StreamFrom blk) deriving (UnknownRange blk -> UnknownRange blk -> Bool (UnknownRange blk -> UnknownRange blk -> Bool) -> (UnknownRange blk -> UnknownRange blk -> Bool) -> Eq (UnknownRange blk) forall blk. StandardHash blk => UnknownRange blk -> UnknownRange blk -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: UnknownRange blk -> UnknownRange blk -> Bool $c/= :: forall blk. StandardHash blk => UnknownRange blk -> UnknownRange blk -> Bool == :: UnknownRange blk -> UnknownRange blk -> Bool $c== :: forall blk. StandardHash blk => UnknownRange blk -> UnknownRange blk -> Bool Eq, Int -> UnknownRange blk -> ShowS [UnknownRange blk] -> ShowS UnknownRange blk -> [Char] (Int -> UnknownRange blk -> ShowS) -> (UnknownRange blk -> [Char]) -> ([UnknownRange blk] -> ShowS) -> Show (UnknownRange blk) forall blk. StandardHash blk => Int -> UnknownRange blk -> ShowS forall blk. StandardHash blk => [UnknownRange blk] -> ShowS forall blk. StandardHash blk => UnknownRange blk -> [Char] forall a. (Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a showList :: [UnknownRange blk] -> ShowS $cshowList :: forall blk. StandardHash blk => [UnknownRange blk] -> ShowS show :: UnknownRange blk -> [Char] $cshow :: forall blk. StandardHash blk => UnknownRange blk -> [Char] showsPrec :: Int -> UnknownRange blk -> ShowS $cshowsPrec :: forall blk. StandardHash blk => Int -> UnknownRange blk -> ShowS Show) -- | Stream all blocks from the current chain. streamAll :: (MonadSTM m, HasHeader blk, HasCallStack) => ChainDB m blk -> ResourceRegistry m -> BlockComponent blk b -> m (Iterator m blk b) streamAll :: ChainDB m blk -> ResourceRegistry m -> BlockComponent blk b -> m (Iterator m blk b) streamAll = StreamFrom blk -> ChainDB m blk -> ResourceRegistry m -> BlockComponent blk b -> m (Iterator m blk b) forall (m :: * -> *) blk b. (MonadSTM m, HasHeader blk, HasCallStack) => StreamFrom blk -> ChainDB m blk -> ResourceRegistry m -> BlockComponent blk b -> m (Iterator m blk b) streamFrom (Point blk -> StreamFrom blk forall blk. Point blk -> StreamFrom blk StreamFromExclusive Point blk forall block. Point block GenesisPoint) -- | Stream blocks from the given point up to the tip from the current chain. -- -- To stream all blocks from the current chain from the ChainDB, one would use -- @'StreamFromExclusive' 'genesisPoint'@ as the lower bound and -- @'StreamToInclusive' tip@ as the upper bound where @tip@ is retrieved with -- 'getTipPoint'. -- -- However, when the ChainDB is empty, @tip@ will be 'genesisPoint' too, in -- which case the bounds don't make sense. This function correctly handles -- this case. -- -- Note that this is not a 'Follower', so the stream will not include blocks -- that are added to the current chain after starting the stream. streamFrom :: (MonadSTM m, HasHeader blk, HasCallStack) => StreamFrom blk -> ChainDB m blk -> ResourceRegistry m -> BlockComponent blk b -> m (Iterator m blk b) streamFrom :: StreamFrom blk -> ChainDB m blk -> ResourceRegistry m -> BlockComponent blk b -> m (Iterator m blk b) streamFrom StreamFrom blk from ChainDB m blk db ResourceRegistry m registry BlockComponent blk b blockComponent = do Point blk tip <- STM m (Point blk) -> m (Point blk) forall (m :: * -> *) a. (MonadSTM m, HasCallStack) => STM m a -> m a atomically (STM m (Point blk) -> m (Point blk)) -> STM m (Point blk) -> m (Point blk) forall a b. (a -> b) -> a -> b $ ChainDB m blk -> STM m (Point blk) forall (m :: * -> *) blk. ChainDB m blk -> STM m (Point blk) getTipPoint ChainDB m blk db case Point blk -> WithOrigin (RealPoint blk) forall blk. Point blk -> WithOrigin (RealPoint blk) pointToWithOriginRealPoint Point blk tip of WithOrigin (RealPoint blk) Origin -> Iterator m blk b -> m (Iterator m blk b) forall (m :: * -> *) a. Monad m => a -> m a return Iterator m blk b forall (m :: * -> *) blk b. Monad m => Iterator m blk b emptyIterator NotOrigin RealPoint blk tip' -> do Either (UnknownRange blk) (Iterator m blk b) errIt <- ChainDB m blk -> ResourceRegistry m -> BlockComponent blk b -> StreamFrom blk -> StreamTo blk -> m (Either (UnknownRange blk) (Iterator m blk b)) forall (m :: * -> *) blk. ChainDB m blk -> forall b. ResourceRegistry m -> BlockComponent blk b -> StreamFrom blk -> StreamTo blk -> m (Either (UnknownRange blk) (Iterator m blk b)) stream ChainDB m blk db ResourceRegistry m registry BlockComponent blk b blockComponent StreamFrom blk from (RealPoint blk -> StreamTo blk forall blk. RealPoint blk -> StreamTo blk StreamToInclusive RealPoint blk tip') case Either (UnknownRange blk) (Iterator m blk b) errIt of Right Iterator m blk b it -> Iterator m blk b -> m (Iterator m blk b) forall (m :: * -> *) a. Monad m => a -> m a return Iterator m blk b it Left UnknownRange blk e -> [Char] -> m (Iterator m blk b) forall a. HasCallStack => [Char] -> a error ([Char] -> m (Iterator m blk b)) -> [Char] -> m (Iterator m blk b) forall a b. (a -> b) -> a -> b $ [Char] "failed to stream from genesis to tip: " [Char] -> ShowS forall a. Semigroup a => a -> a -> a <> UnknownRange blk -> [Char] forall a. Show a => a -> [Char] show UnknownRange blk e {------------------------------------------------------------------------------- Invalid block reason -------------------------------------------------------------------------------} -- | The reason why a block is invalid. data InvalidBlockReason blk = ValidationError !(ExtValidationError blk) -- ^ The ledger found the block to be invalid. | InFutureExceedsClockSkew !(RealPoint blk) -- ^ The block's slot is in the future, exceeding the allowed clock skew. -- -- Possible causes, order by decreasing likelihood: -- -- 1. Our clock is behind (significantly more likely than the others) -- 2. Their clock is ahead -- 3. It's intentional, i.e., an attack deriving (InvalidBlockReason blk -> InvalidBlockReason blk -> Bool (InvalidBlockReason blk -> InvalidBlockReason blk -> Bool) -> (InvalidBlockReason blk -> InvalidBlockReason blk -> Bool) -> Eq (InvalidBlockReason blk) forall blk. LedgerSupportsProtocol blk => InvalidBlockReason blk -> InvalidBlockReason blk -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: InvalidBlockReason blk -> InvalidBlockReason blk -> Bool $c/= :: forall blk. LedgerSupportsProtocol blk => InvalidBlockReason blk -> InvalidBlockReason blk -> Bool == :: InvalidBlockReason blk -> InvalidBlockReason blk -> Bool $c== :: forall blk. LedgerSupportsProtocol blk => InvalidBlockReason blk -> InvalidBlockReason blk -> Bool Eq, Int -> InvalidBlockReason blk -> ShowS [InvalidBlockReason blk] -> ShowS InvalidBlockReason blk -> [Char] (Int -> InvalidBlockReason blk -> ShowS) -> (InvalidBlockReason blk -> [Char]) -> ([InvalidBlockReason blk] -> ShowS) -> Show (InvalidBlockReason blk) forall blk. LedgerSupportsProtocol blk => Int -> InvalidBlockReason blk -> ShowS forall blk. LedgerSupportsProtocol blk => [InvalidBlockReason blk] -> ShowS forall blk. LedgerSupportsProtocol blk => InvalidBlockReason blk -> [Char] forall a. (Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a showList :: [InvalidBlockReason blk] -> ShowS $cshowList :: forall blk. LedgerSupportsProtocol blk => [InvalidBlockReason blk] -> ShowS show :: InvalidBlockReason blk -> [Char] $cshow :: forall blk. LedgerSupportsProtocol blk => InvalidBlockReason blk -> [Char] showsPrec :: Int -> InvalidBlockReason blk -> ShowS $cshowsPrec :: forall blk. LedgerSupportsProtocol blk => Int -> InvalidBlockReason blk -> ShowS Show, (forall x. InvalidBlockReason blk -> Rep (InvalidBlockReason blk) x) -> (forall x. Rep (InvalidBlockReason blk) x -> InvalidBlockReason blk) -> Generic (InvalidBlockReason blk) forall x. Rep (InvalidBlockReason blk) x -> InvalidBlockReason blk forall x. InvalidBlockReason blk -> Rep (InvalidBlockReason blk) x forall a. (forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a forall blk x. Rep (InvalidBlockReason blk) x -> InvalidBlockReason blk forall blk x. InvalidBlockReason blk -> Rep (InvalidBlockReason blk) x $cto :: forall blk x. Rep (InvalidBlockReason blk) x -> InvalidBlockReason blk $cfrom :: forall blk x. InvalidBlockReason blk -> Rep (InvalidBlockReason blk) x Generic) instance LedgerSupportsProtocol blk => NoThunks (InvalidBlockReason blk) {------------------------------------------------------------------------------- Followers -------------------------------------------------------------------------------} -- | Chain type -- -- 'Follower's can choose to track changes to the "normal" 'SelectedChain', or -- track the 'TentativeChain', which might contain a pipelineable header at the -- tip. data ChainType = SelectedChain | TentativeChain deriving (ChainType -> ChainType -> Bool (ChainType -> ChainType -> Bool) -> (ChainType -> ChainType -> Bool) -> Eq ChainType forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: ChainType -> ChainType -> Bool $c/= :: ChainType -> ChainType -> Bool == :: ChainType -> ChainType -> Bool $c== :: ChainType -> ChainType -> Bool Eq, Int -> ChainType -> ShowS [ChainType] -> ShowS ChainType -> [Char] (Int -> ChainType -> ShowS) -> (ChainType -> [Char]) -> ([ChainType] -> ShowS) -> Show ChainType forall a. (Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a showList :: [ChainType] -> ShowS $cshowList :: [ChainType] -> ShowS show :: ChainType -> [Char] $cshow :: ChainType -> [Char] showsPrec :: Int -> ChainType -> ShowS $cshowsPrec :: Int -> ChainType -> ShowS Show, (forall x. ChainType -> Rep ChainType x) -> (forall x. Rep ChainType x -> ChainType) -> Generic ChainType forall x. Rep ChainType x -> ChainType forall x. ChainType -> Rep ChainType x forall a. (forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a $cto :: forall x. Rep ChainType x -> ChainType $cfrom :: forall x. ChainType -> Rep ChainType x Generic) -- | Follower -- -- See 'newFollower' for more info. -- -- The type parameter @a@ will be instantiated with @blk@ or @Header @blk@. data Follower m blk a = Follower { -- | The next chain update (if one exists) -- -- Not in @STM@ because might have to read the blocks or headers from -- disk. -- -- We may roll back more than @k@, but only in case of data loss. Follower m blk a -> m (Maybe (ChainUpdate blk a)) followerInstruction :: m (Maybe (ChainUpdate blk a)) -- | Blocking version of 'followerInstruction' , Follower m blk a -> m (ChainUpdate blk a) followerInstructionBlocking :: m (ChainUpdate blk a) -- | Move the follower forward -- -- Must be given a list of points in order of preference; the iterator -- will move forward to the first point on the list that is on the current -- chain. Returns 'Nothing' if the iterator did not move, or the new point -- otherwise. -- -- When successful, the first call to 'followerInstruction' after -- 'followerForward' will be a 'RollBack' to the point returned by -- 'followerForward'. -- -- Cannot live in @STM@ because the points specified might live in the -- immutable DB. , Follower m blk a -> [Point blk] -> m (Maybe (Point blk)) followerForward :: [Point blk] -> m (Maybe (Point blk)) -- | Close the follower. -- -- Idempotent. -- -- After closing, all other operations on the follower will throw -- 'ClosedFollowerError'. , Follower m blk a -> m () followerClose :: m () } deriving (a -> Follower m blk b -> Follower m blk a (a -> b) -> Follower m blk a -> Follower m blk b (forall a b. (a -> b) -> Follower m blk a -> Follower m blk b) -> (forall a b. a -> Follower m blk b -> Follower m blk a) -> Functor (Follower m blk) forall a b. a -> Follower m blk b -> Follower m blk a forall a b. (a -> b) -> Follower m blk a -> Follower m blk b forall (f :: * -> *). (forall a b. (a -> b) -> f a -> f b) -> (forall a b. a -> f b -> f a) -> Functor f forall (m :: * -> *) blk a b. Functor m => a -> Follower m blk b -> Follower m blk a forall (m :: * -> *) blk a b. Functor m => (a -> b) -> Follower m blk a -> Follower m blk b <$ :: a -> Follower m blk b -> Follower m blk a $c<$ :: forall (m :: * -> *) blk a b. Functor m => a -> Follower m blk b -> Follower m blk a fmap :: (a -> b) -> Follower m blk a -> Follower m blk b $cfmap :: forall (m :: * -> *) blk a b. Functor m => (a -> b) -> Follower m blk a -> Follower m blk b Functor) -- | Variant of 'traverse' instantiated to @'Follower' m blk@ that executes the -- monadic function when calling 'followerInstruction' and -- 'followerInstructionBlocking'. traverseFollower :: Monad m => (b -> m b') -> Follower m blk b -> Follower m blk b' traverseFollower :: (b -> m b') -> Follower m blk b -> Follower m blk b' traverseFollower b -> m b' f Follower m blk b flr = Follower :: forall (m :: * -> *) blk a. m (Maybe (ChainUpdate blk a)) -> m (ChainUpdate blk a) -> ([Point blk] -> m (Maybe (Point blk))) -> m () -> Follower m blk a Follower { followerInstruction :: m (Maybe (ChainUpdate blk b')) followerInstruction = Follower m blk b -> m (Maybe (ChainUpdate blk b)) forall (m :: * -> *) blk a. Follower m blk a -> m (Maybe (ChainUpdate blk a)) followerInstruction Follower m blk b flr m (Maybe (ChainUpdate blk b)) -> (Maybe (ChainUpdate blk b) -> m (Maybe (ChainUpdate blk b'))) -> m (Maybe (ChainUpdate blk b')) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= (ChainUpdate blk b -> m (ChainUpdate blk b')) -> Maybe (ChainUpdate blk b) -> m (Maybe (ChainUpdate blk b')) forall (t :: * -> *) (f :: * -> *) a b. (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) traverse ((b -> m b') -> ChainUpdate blk b -> m (ChainUpdate blk b') forall (t :: * -> *) (f :: * -> *) a b. (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) traverse b -> m b' f) , followerInstructionBlocking :: m (ChainUpdate blk b') followerInstructionBlocking = Follower m blk b -> m (ChainUpdate blk b) forall (m :: * -> *) blk a. Follower m blk a -> m (ChainUpdate blk a) followerInstructionBlocking Follower m blk b flr m (ChainUpdate blk b) -> (ChainUpdate blk b -> m (ChainUpdate blk b')) -> m (ChainUpdate blk b') forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= (b -> m b') -> ChainUpdate blk b -> m (ChainUpdate blk b') forall (t :: * -> *) (f :: * -> *) a b. (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) traverse b -> m b' f , followerForward :: [Point blk] -> m (Maybe (Point blk)) followerForward = Follower m blk b -> [Point blk] -> m (Maybe (Point blk)) forall (m :: * -> *) blk a. Follower m blk a -> [Point blk] -> m (Maybe (Point blk)) followerForward Follower m blk b flr , followerClose :: m () followerClose = Follower m blk b -> m () forall (m :: * -> *) blk a. Follower m blk a -> m () followerClose Follower m blk b flr } {------------------------------------------------------------------------------- Recovery -------------------------------------------------------------------------------} -- | Database failure -- -- This exception wraps any kind of unexpected problem with the on-disk -- storage of the chain. -- -- The various constructors only serve to give more detailed information about -- what went wrong, in case sysadmins want to investigate the disk failure. -- The Chain DB itself does not differentiate; all disk failures are treated -- equal and all trigger the same recovery procedure. data ChainDbFailure blk = -- | The ledger DB threw a file-system error LgrDbFailure FsError -- | Block missing from the chain DB -- -- Thrown when we are not sure in which DB the block /should/ have been. | ChainDbMissingBlock (RealPoint blk) deriving (Typeable) deriving instance StandardHash blk => Show (ChainDbFailure blk) instance (Typeable blk, StandardHash blk) => Exception (ChainDbFailure blk) where displayException :: ChainDbFailure blk -> [Char] displayException = \case LgrDbFailure FsError fse -> FsError -> [Char] fsError FsError fse ChainDbMissingBlock {} -> [Char] corruption where corruption :: [Char] corruption = [Char] "The database got corrupted, full validation will be enabled for the next startup" -- The output will be a bit too detailed, but it will be quite clear. fsError :: FsError -> String fsError :: FsError -> [Char] fsError = FsError -> [Char] forall e. Exception e => e -> [Char] displayException {------------------------------------------------------------------------------- Exceptions -------------------------------------------------------------------------------} -- | Database error -- -- Thrown upon incorrect use: invalid input. data ChainDbError blk = -- | The ChainDB is closed. -- -- This will be thrown when performing any operation on the ChainDB except -- for 'isOpen' and 'closeDB'. The 'CallStack' of the operation on the -- ChainDB is included in the error. ClosedDBError PrettyCallStack -- | The follower is closed. -- -- This will be thrown when performing any operation on a closed followers, -- except for 'followerClose'. | ClosedFollowerError -- | When there is no chain/fork that satisfies the bounds passed to -- 'streamBlocks'. -- -- * The lower and upper bound are not on the same chain. -- * The bounds don't make sense, e.g., the lower bound starts after the -- upper bound, or the lower bound starts from genesis, /inclusive/. | InvalidIteratorRange (StreamFrom blk) (StreamTo blk) deriving (Typeable) deriving instance (Typeable blk, StandardHash blk) => Show (ChainDbError blk) instance (Typeable blk, StandardHash blk) => Exception (ChainDbError blk) where displayException :: ChainDbError blk -> [Char] displayException = \case -- The user should not see the exception below, a fatal exception with -- more information about the specific will have been thrown. This -- exception will only be thrown if some thread still tries to use the -- ChainDB afterwards, which should not happen. ClosedDBError {} -> [Char] "The database was used after it was closed because it encountered an unrecoverable error" -- The user won't see the exceptions below, they are not fatal. ClosedFollowerError {} -> [Char] "The block/header follower was used after it was closed" InvalidIteratorRange {} -> [Char] "An invalid range of blocks was requested"