{-# 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 immutable 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.
    , 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"