{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE GADTs                #-}
{-# LANGUAGE LambdaCase           #-}
{-# LANGUAGE MultiWayIf           #-}
{-# LANGUAGE NamedFieldPuns       #-}
{-# LANGUAGE PatternSynonyms      #-}
{-# LANGUAGE RecordWildCards      #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE StandaloneDeriving   #-}
{-# LANGUAGE TypeApplications     #-}
{-# LANGUAGE UndecidableInstances #-}

-- | Operations involving chain selection: the initial chain selection and
-- adding a block.
module Ouroboros.Consensus.Storage.ChainDB.Impl.ChainSel
  ( initialChainSelection
  , addBlockAsync
  , addBlockSync
  , chainSelectionForBlock
    -- * Exported for testing purposes
  , olderThanK
  ) where

import           Control.Exception (assert)
import           Control.Monad.Except
import           Control.Monad.Trans.State.Strict
import           Control.Tracer (Tracer, contramap, traceWith)
import           Data.Function (on)
import           Data.List (partition, sortBy)
import           Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NE
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           Data.Maybe (isJust)
import           Data.Set (Set)
import qualified Data.Set as Set
import           GHC.Stack (HasCallStack)

import           Ouroboros.Network.AnchoredFragment (Anchor,
                     AnchoredFragment (..))
import qualified Ouroboros.Network.AnchoredFragment as AF

import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Config
import           Ouroboros.Consensus.Fragment.InFuture (CheckInFuture (..))
import qualified Ouroboros.Consensus.Fragment.InFuture as InFuture
import           Ouroboros.Consensus.Fragment.Validated (ValidatedFragment)
import qualified Ouroboros.Consensus.Fragment.Validated as VF
import           Ouroboros.Consensus.HardFork.Abstract
import qualified Ouroboros.Consensus.HardFork.History as History
import           Ouroboros.Consensus.Ledger.Abstract
import           Ouroboros.Consensus.Ledger.Extended
import           Ouroboros.Consensus.Ledger.Inspect
import           Ouroboros.Consensus.Ledger.SupportsProtocol
import           Ouroboros.Consensus.Util.AnchoredFragment
import           Ouroboros.Consensus.Util.IOLike
import           Ouroboros.Consensus.Util.STM (WithFingerprint (..))

import           Ouroboros.Consensus.Fragment.Diff (ChainDiff (..))
import qualified Ouroboros.Consensus.Fragment.Diff as Diff
import           Ouroboros.Consensus.Fragment.ValidatedDiff
                     (ValidatedChainDiff (..))
import qualified Ouroboros.Consensus.Fragment.ValidatedDiff as ValidatedDiff
import           Ouroboros.Consensus.Storage.ChainDB.API (AddBlockPromise (..),
                     BlockComponent (..), InvalidBlockReason (..))
import           Ouroboros.Consensus.Storage.ChainDB.Impl.BlockCache
                     (BlockCache)
import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.BlockCache as BlockCache
import           Ouroboros.Consensus.Storage.ChainDB.Impl.LgrDB (LedgerDB',
                     LgrDB)
import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.LgrDB as LgrDB
import           Ouroboros.Consensus.Storage.ChainDB.Impl.Paths
                     (LookupBlockInfo)
import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.Paths as Paths
import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.Query as Query
import           Ouroboros.Consensus.Storage.ChainDB.Impl.Types
import           Ouroboros.Consensus.Storage.ImmutableDB (ImmutableDB)
import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB
import           Ouroboros.Consensus.Storage.VolatileDB (VolatileDB)
import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB

-- | Perform the initial chain selection based on the tip of the ImmutableDB
-- and the contents of the VolatileDB.
--
-- Returns the chosen validated chain and corresponding ledger.
--
-- See "## Initialization" in ChainDB.md.
initialChainSelection
  :: forall m blk. (IOLike m, LedgerSupportsProtocol blk)
  => ImmutableDB m blk
  -> VolatileDB m blk
  -> LgrDB m blk
  -> Tracer m (TraceEvent blk)
  -> TopLevelConfig blk
  -> StrictTVar m (WithFingerprint (InvalidBlocks blk))
  -> StrictTVar m (FutureBlocks blk)
  -> CheckInFuture m blk
  -> m (ChainAndLedger blk)
initialChainSelection :: ImmutableDB m blk
-> VolatileDB m blk
-> LgrDB m blk
-> Tracer m (TraceEvent blk)
-> TopLevelConfig blk
-> StrictTVar m (WithFingerprint (InvalidBlocks blk))
-> StrictTVar m (FutureBlocks blk)
-> CheckInFuture m blk
-> m (ChainAndLedger blk)
initialChainSelection ImmutableDB m blk
immutableDB VolatileDB m blk
volatileDB LgrDB m blk
lgrDB Tracer m (TraceEvent blk)
tracer TopLevelConfig blk
cfg StrictTVar m (WithFingerprint (InvalidBlocks blk))
varInvalid
                      StrictTVar m (FutureBlocks blk)
varFutureBlocks CheckInFuture m blk
futureCheck = do
    -- We follow the steps from section "## Initialization" in ChainDB.md

    (Anchor blk
i :: Anchor blk, ChainHash blk -> Set (HeaderHash blk)
succsOf, LedgerDB' blk
ledger) <- STM
  m
  (Anchor blk, ChainHash blk -> Set (HeaderHash blk), LedgerDB' blk)
-> m (Anchor blk, ChainHash blk -> Set (HeaderHash blk),
      LedgerDB' blk)
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM
   m
   (Anchor blk, ChainHash blk -> Set (HeaderHash blk), LedgerDB' blk)
 -> m (Anchor blk, ChainHash blk -> Set (HeaderHash blk),
       LedgerDB' blk))
-> STM
     m
     (Anchor blk, ChainHash blk -> Set (HeaderHash blk), LedgerDB' blk)
-> m (Anchor blk, ChainHash blk -> Set (HeaderHash blk),
      LedgerDB' blk)
forall a b. (a -> b) -> a -> b
$ do
      InvalidBlocks blk
invalid <- WithFingerprint (InvalidBlocks blk) -> InvalidBlocks blk
forall a. WithFingerprint a -> a
forgetFingerprint (WithFingerprint (InvalidBlocks blk) -> InvalidBlocks blk)
-> STM m (WithFingerprint (InvalidBlocks blk))
-> STM m (InvalidBlocks blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m (WithFingerprint (InvalidBlocks blk))
-> STM m (WithFingerprint (InvalidBlocks blk))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (WithFingerprint (InvalidBlocks blk))
varInvalid
      (,,)
        (Anchor blk
 -> (ChainHash blk -> Set (HeaderHash blk))
 -> LedgerDB' blk
 -> (Anchor blk, ChainHash blk -> Set (HeaderHash blk),
     LedgerDB' blk))
-> STM m (Anchor blk)
-> STM
     m
     ((ChainHash blk -> Set (HeaderHash blk))
      -> LedgerDB' blk
      -> (Anchor blk, ChainHash blk -> Set (HeaderHash blk),
          LedgerDB' blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImmutableDB m blk -> STM m (Anchor blk)
forall (m :: * -> *) blk.
(MonadSTM m, HasCallStack) =>
ImmutableDB m blk -> STM m (Anchor blk)
ImmutableDB.getTipAnchor ImmutableDB m blk
immutableDB
        STM
  m
  ((ChainHash blk -> Set (HeaderHash blk))
   -> LedgerDB' blk
   -> (Anchor blk, ChainHash blk -> Set (HeaderHash blk),
       LedgerDB' blk))
-> STM m (ChainHash blk -> Set (HeaderHash blk))
-> STM
     m
     (LedgerDB' blk
      -> (Anchor blk, ChainHash blk -> Set (HeaderHash blk),
          LedgerDB' blk))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (VolatileDB m blk
-> InvalidBlocks blk
-> (ChainHash blk -> Set (HeaderHash blk))
-> ChainHash blk
-> Set (HeaderHash blk)
forall blk (proxy :: * -> *).
HasHeader blk =>
proxy blk
-> InvalidBlocks blk
-> (ChainHash blk -> Set (HeaderHash blk))
-> ChainHash blk
-> Set (HeaderHash blk)
ignoreInvalidSuc VolatileDB m blk
volatileDB InvalidBlocks blk
invalid ((ChainHash blk -> Set (HeaderHash blk))
 -> ChainHash blk -> Set (HeaderHash blk))
-> STM m (ChainHash blk -> Set (HeaderHash blk))
-> STM m (ChainHash blk -> Set (HeaderHash blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
              VolatileDB m blk
-> HasCallStack => STM m (ChainHash blk -> Set (HeaderHash blk))
forall (m :: * -> *) blk.
VolatileDB m blk
-> HasCallStack => STM m (ChainHash blk -> Set (HeaderHash blk))
VolatileDB.filterByPredecessor VolatileDB m blk
volatileDB)
        STM
  m
  (LedgerDB' blk
   -> (Anchor blk, ChainHash blk -> Set (HeaderHash blk),
       LedgerDB' blk))
-> STM m (LedgerDB' blk)
-> STM
     m
     (Anchor blk, ChainHash blk -> Set (HeaderHash blk), LedgerDB' blk)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LgrDB m blk -> STM m (LedgerDB' blk)
forall (m :: * -> *) blk.
IOLike m =>
LgrDB m blk -> STM m (LedgerDB' blk)
LgrDB.getCurrent LgrDB m blk
lgrDB

    [AnchoredFragment (Header blk)]
chains <- Anchor blk
-> (ChainHash blk -> Set (HeaderHash blk))
-> m [AnchoredFragment (Header blk)]
constructChains Anchor blk
i ChainHash blk -> Set (HeaderHash blk)
succsOf

    -- We use the empty fragment anchored at @i@ as the current chain (and
    -- ledger) and the default in case there is no better candidate.
    let curChain :: AnchoredFragment (Header blk)
curChain          = Anchor (Header blk) -> AnchoredFragment (Header blk)
forall block.
HasHeader block =>
Anchor block -> AnchoredFragment block
Empty (Anchor blk -> Anchor (Header blk)
forall a b. (HeaderHash a ~ HeaderHash b) => Anchor a -> Anchor b
AF.castAnchor Anchor blk
i)
        curChainAndLedger :: ChainAndLedger blk
curChainAndLedger = AnchoredFragment (Header blk)
-> LedgerDB' blk -> ChainAndLedger blk
forall l b.
(IsLedger l, HasHeader b, HeaderHash b ~ HeaderHash l,
 HasCallStack) =>
AnchoredFragment b -> l -> ValidatedFragment b l
VF.ValidatedFragment AnchoredFragment (Header blk)
curChain LedgerDB' blk
ledger

    case [AnchoredFragment (Header blk)]
-> Maybe (NonEmpty (AnchoredFragment (Header blk)))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty ((AnchoredFragment (Header blk) -> Bool)
-> [AnchoredFragment (Header blk)]
-> [AnchoredFragment (Header blk)]
forall a. (a -> Bool) -> [a] -> [a]
filter (TopLevelConfig blk
-> AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk)
-> Bool
forall blk.
BlockSupportsProtocol blk =>
TopLevelConfig blk
-> AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk)
-> Bool
preferAnchoredCandidate TopLevelConfig blk
cfg AnchoredFragment (Header blk)
curChain) [AnchoredFragment (Header blk)]
chains) of
      -- If there are no candidates, no chain selection is needed
      Maybe (NonEmpty (AnchoredFragment (Header blk)))
Nothing      -> ChainAndLedger blk -> m (ChainAndLedger blk)
forall (m :: * -> *) a. Monad m => a -> m a
return ChainAndLedger blk
curChainAndLedger
      Just NonEmpty (AnchoredFragment (Header blk))
chains' -> ChainAndLedger blk
-> (ValidatedChainDiff (Header blk) (LedgerDB' blk)
    -> ChainAndLedger blk)
-> Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk))
-> ChainAndLedger blk
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ChainAndLedger blk
curChainAndLedger ValidatedChainDiff (Header blk) (LedgerDB' blk)
-> ChainAndLedger blk
toChainAndLedger (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk))
 -> ChainAndLedger blk)
-> m (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
-> m (ChainAndLedger blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        HasCallStack =>
ChainAndLedger blk
-> NonEmpty (AnchoredFragment (Header blk))
-> m (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
ChainAndLedger blk
-> NonEmpty (AnchoredFragment (Header blk))
-> m (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
chainSelection' ChainAndLedger blk
curChainAndLedger NonEmpty (AnchoredFragment (Header blk))
chains'
  where
    -- | Turn the 'ValidatedChainDiff' into a 'ChainAndLedger'.
    --
    -- The rollback of the 'ChainDiff' must be empty, as the suffix starts
    -- from the tip of the ImmutableDB, and we can't roll back past that tip.
    -- This is guaranteed by the fact that all constructed candidates start
    -- from this tip.
    toChainAndLedger
      :: ValidatedChainDiff (Header blk) (LedgerDB' blk)
      -> ChainAndLedger blk
    toChainAndLedger :: ValidatedChainDiff (Header blk) (LedgerDB' blk)
-> ChainAndLedger blk
toChainAndLedger (ValidatedChainDiff ChainDiff (Header blk)
chainDiff LedgerDB' blk
ledger) =
      case ChainDiff (Header blk)
chainDiff of
        ChainDiff Word64
rollback AnchoredFragment (Header blk)
suffix
          | Word64
rollback Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
0
          -> AnchoredFragment (Header blk)
-> LedgerDB' blk -> ChainAndLedger blk
forall l b.
(IsLedger l, HasHeader b, HeaderHash b ~ HeaderHash l,
 HasCallStack) =>
AnchoredFragment b -> l -> ValidatedFragment b l
VF.ValidatedFragment AnchoredFragment (Header blk)
suffix LedgerDB' blk
ledger
          | Bool
otherwise
          -> [Char] -> ChainAndLedger blk
forall a. HasCallStack => [Char] -> a
error [Char]
"constructed an initial chain with rollback"

    -- | Use the VolatileDB to construct all chains starting from the tip of
    -- the ImmutableDB.
    constructChains ::
         Anchor blk -- ^ Tip of the ImmutableDB, @i@
      -> (ChainHash blk -> Set (HeaderHash blk))
      -> m [AnchoredFragment (Header blk)]
    constructChains :: Anchor blk
-> (ChainHash blk -> Set (HeaderHash blk))
-> m [AnchoredFragment (Header blk)]
constructChains Anchor blk
i ChainHash blk -> Set (HeaderHash blk)
succsOf = (StateT (FutureBlocks blk) m [AnchoredFragment (Header blk)]
 -> FutureBlocks blk -> m [AnchoredFragment (Header blk)])
-> FutureBlocks blk
-> StateT (FutureBlocks blk) m [AnchoredFragment (Header blk)]
-> m [AnchoredFragment (Header blk)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT (FutureBlocks blk) m [AnchoredFragment (Header blk)]
-> FutureBlocks blk -> m [AnchoredFragment (Header blk)]
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT FutureBlocks blk
forall k a. Map k a
Map.empty (StateT (FutureBlocks blk) m [AnchoredFragment (Header blk)]
 -> m [AnchoredFragment (Header blk)])
-> StateT (FutureBlocks blk) m [AnchoredFragment (Header blk)]
-> m [AnchoredFragment (Header blk)]
forall a b. (a -> b) -> a -> b
$
        (NonEmpty (HeaderHash blk)
 -> StateT (FutureBlocks blk) m (AnchoredFragment (Header blk)))
-> [NonEmpty (HeaderHash blk)]
-> StateT (FutureBlocks blk) m [AnchoredFragment (Header blk)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM NonEmpty (HeaderHash blk)
-> StateT (FutureBlocks blk) m (AnchoredFragment (Header blk))
constructChain [NonEmpty (HeaderHash blk)]
suffixesAfterI
      where
        suffixesAfterI :: [NonEmpty (HeaderHash blk)]
        suffixesAfterI :: [NonEmpty (HeaderHash blk)]
suffixesAfterI = (ChainHash blk -> Set (HeaderHash blk))
-> Point blk -> [NonEmpty (HeaderHash blk)]
forall blk.
(ChainHash blk -> Set (HeaderHash blk))
-> Point blk -> [NonEmpty (HeaderHash blk)]
Paths.candidates ChainHash blk -> Set (HeaderHash blk)
succsOf (Anchor blk -> Point blk
forall block. Anchor block -> Point block
AF.anchorToPoint Anchor blk
i)

        constructChain ::
             NonEmpty (HeaderHash blk)
          -> StateT (Map (HeaderHash blk) (Header blk))
                    m
                    (AnchoredFragment (Header blk))
        constructChain :: NonEmpty (HeaderHash blk)
-> StateT (FutureBlocks blk) m (AnchoredFragment (Header blk))
constructChain NonEmpty (HeaderHash blk)
hashes =
            Anchor (Header blk)
-> [Header blk] -> AnchoredFragment (Header blk)
forall block.
HasHeader block =>
Anchor block -> [block] -> AnchoredFragment block
AF.fromOldestFirst (Anchor blk -> Anchor (Header blk)
forall a b. (HeaderHash a ~ HeaderHash b) => Anchor a -> Anchor b
AF.castAnchor Anchor blk
i) ([Header blk] -> AnchoredFragment (Header blk))
-> StateT (FutureBlocks blk) m [Header blk]
-> StateT (FutureBlocks blk) m (AnchoredFragment (Header blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            (HeaderHash blk -> StateT (FutureBlocks blk) m (Header blk))
-> [HeaderHash blk] -> StateT (FutureBlocks blk) m [Header blk]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (VolatileDB m blk
-> HeaderHash blk -> StateT (FutureBlocks blk) m (Header blk)
forall (m :: * -> *) blk.
(MonadThrow m, HasHeader blk) =>
VolatileDB m blk
-> HeaderHash blk
-> StateT (Map (HeaderHash blk) (Header blk)) m (Header blk)
getKnownHeaderThroughCache VolatileDB m blk
volatileDB) (NonEmpty (HeaderHash blk) -> [HeaderHash blk]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty (HeaderHash blk)
hashes)

    -- | Perform chain selection (including validation) on the given
    -- candidates.
    --
    -- PRECONDITION: all candidates are anchored at @i@.
    --
    -- PRECONDITION: all candidates must be preferred over the current chain.
    chainSelection' ::
         HasCallStack
      => ChainAndLedger blk
         -- ^ The current chain and ledger, corresponding to
         -- @i@.
      -> NonEmpty (AnchoredFragment (Header blk))
         -- ^ Candidates anchored at @i@
      -> m (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
    chainSelection' :: ChainAndLedger blk
-> NonEmpty (AnchoredFragment (Header blk))
-> m (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
chainSelection' ChainAndLedger blk
curChainAndLedger NonEmpty (AnchoredFragment (Header blk))
candidates =
        Bool
-> m (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
-> m (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
forall a. HasCallStack => Bool -> a -> a
assert ((AnchoredFragment (Header blk) -> Bool)
-> NonEmpty (AnchoredFragment (Header blk)) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((LedgerDB' blk -> Point blk
forall blk. UpdateLedger blk => LedgerDB' blk -> Point blk
LgrDB.currentPoint LedgerDB' blk
ledger Point blk -> Point blk -> Bool
forall a. Eq a => a -> a -> Bool
==) (Point blk -> Bool)
-> (AnchoredFragment (Header blk) -> Point blk)
-> AnchoredFragment (Header blk)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                     Point (Header blk) -> Point blk
forall b b'.
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point (Header blk) -> Point blk)
-> (AnchoredFragment (Header blk) -> Point (Header blk))
-> AnchoredFragment (Header blk)
-> Point blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredFragment (Header blk) -> Point (Header blk)
forall block. AnchoredFragment block -> Point block
AF.anchorPoint)
                    NonEmpty (AnchoredFragment (Header blk))
candidates) (m (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
 -> m (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk))))
-> m (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
-> m (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
forall a b. (a -> b) -> a -> b
$
        Bool
-> m (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
-> m (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
forall a. HasCallStack => Bool -> a -> a
assert ((AnchoredFragment (Header blk) -> Bool)
-> NonEmpty (AnchoredFragment (Header blk)) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (TopLevelConfig blk
-> AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk)
-> Bool
forall blk.
BlockSupportsProtocol blk =>
TopLevelConfig blk
-> AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk)
-> Bool
preferAnchoredCandidate TopLevelConfig blk
cfg AnchoredFragment (Header blk)
curChain) NonEmpty (AnchoredFragment (Header blk))
candidates) (m (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
 -> m (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk))))
-> m (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
-> m (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
forall a b. (a -> b) -> a -> b
$
        ChainSelEnv m blk
-> NonEmpty (ChainDiff (Header blk))
-> m (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsProtocol blk, HasCallStack) =>
ChainSelEnv m blk
-> NonEmpty (ChainDiff (Header blk))
-> m (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
chainSelection ChainSelEnv m blk
chainSelEnv (AnchoredFragment (Header blk) -> ChainDiff (Header blk)
forall b. AnchoredFragment b -> ChainDiff b
Diff.extend (AnchoredFragment (Header blk) -> ChainDiff (Header blk))
-> NonEmpty (AnchoredFragment (Header blk))
-> NonEmpty (ChainDiff (Header blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (AnchoredFragment (Header blk))
candidates)
      where
        curChain :: AnchoredFragment (Header blk)
curChain = ChainAndLedger blk -> AnchoredFragment (Header blk)
forall b l. ValidatedFragment b l -> AnchoredFragment b
VF.validatedFragment ChainAndLedger blk
curChainAndLedger
        ledger :: LedgerDB' blk
ledger   = ChainAndLedger blk -> LedgerDB' blk
forall b l. ValidatedFragment b l -> l
VF.validatedLedger   ChainAndLedger blk
curChainAndLedger
        chainSelEnv :: ChainSelEnv m blk
chainSelEnv = ChainSelEnv :: forall (m :: * -> *) blk.
LgrDB m blk
-> (TraceValidationEvent blk -> m ())
-> TopLevelConfig blk
-> StrictTVar m (WithFingerprint (InvalidBlocks blk))
-> StrictTVar m (FutureBlocks blk)
-> CheckInFuture m blk
-> BlockCache blk
-> ChainAndLedger blk
-> ChainSelEnv m blk
ChainSelEnv
          { LgrDB m blk
lgrDB :: LgrDB m blk
lgrDB :: LgrDB m blk
lgrDB
          , TopLevelConfig blk
cfg :: TopLevelConfig blk
cfg :: TopLevelConfig blk
cfg
          , StrictTVar m (WithFingerprint (InvalidBlocks blk))
varInvalid :: StrictTVar m (WithFingerprint (InvalidBlocks blk))
varInvalid :: StrictTVar m (WithFingerprint (InvalidBlocks blk))
varInvalid
          , StrictTVar m (FutureBlocks blk)
varFutureBlocks :: StrictTVar m (FutureBlocks blk)
varFutureBlocks :: StrictTVar m (FutureBlocks blk)
varFutureBlocks
          , CheckInFuture m blk
futureCheck :: CheckInFuture m blk
futureCheck :: CheckInFuture m blk
futureCheck
          , blockCache :: BlockCache blk
blockCache = BlockCache blk
forall blk. BlockCache blk
BlockCache.empty
          , ChainAndLedger blk
curChainAndLedger :: ChainAndLedger blk
curChainAndLedger :: ChainAndLedger blk
curChainAndLedger
          , trace :: TraceValidationEvent blk -> m ()
trace = Tracer m (TraceValidationEvent blk)
-> TraceValidationEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith
              ((TraceValidationEvent blk -> TraceEvent blk)
-> Tracer m (TraceEvent blk) -> Tracer m (TraceValidationEvent blk)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (TraceInitChainSelEvent blk -> TraceEvent blk
forall blk. TraceInitChainSelEvent blk -> TraceEvent blk
TraceInitChainSelEvent (TraceInitChainSelEvent blk -> TraceEvent blk)
-> (TraceValidationEvent blk -> TraceInitChainSelEvent blk)
-> TraceValidationEvent blk
-> TraceEvent blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TraceValidationEvent blk -> TraceInitChainSelEvent blk
forall blk. TraceValidationEvent blk -> TraceInitChainSelEvent blk
InitChainSelValidation) Tracer m (TraceEvent blk)
tracer)
          }

-- | Add a block to the ChainDB, /asynchronously/.
--
-- This adds a 'BlockToAdd' corresponding to the given block to the
-- 'cdbBlocksToAdd' queue. The entries in that queue are processed using
-- 'addBlockSync', see that function for more information.
--
-- When the queue is full, this function will still block.
--
-- An important advantage of this asynchronous approach over a synchronous
-- approach is that it doesn't have the following disadvantage: when a thread
-- adding a block to the ChainDB is killed, which can happen when
-- disconnecting from the corresponding node, we might have written the block
-- to disk, but not updated the corresponding in-memory state (e.g., that of
-- the VolatileDB), leaving both out of sync.
--
-- With this asynchronous approach, threads adding blocks asynchronously can
-- be killed without worries, the background thread processing the blocks
-- synchronously won't be killed. Only when the whole ChainDB shuts down will
-- that background thread get killed. But since there will be no more
-- in-memory state, it can't get out of sync with the file system state. On
-- the next startup, a correct in-memory state will be reconstructed from the
-- file system state.
addBlockAsync
  :: forall m blk. (IOLike m, HasHeader blk)
  => ChainDbEnv m blk
  -> blk
  -> m (AddBlockPromise m blk)
addBlockAsync :: ChainDbEnv m blk -> blk -> m (AddBlockPromise m blk)
addBlockAsync CDB { Tracer m (TraceEvent blk)
cdbTracer :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> Tracer m (TraceEvent blk)
cdbTracer :: Tracer m (TraceEvent blk)
cdbTracer, BlocksToAdd m blk
cdbBlocksToAdd :: forall (m :: * -> *) blk. ChainDbEnv m blk -> BlocksToAdd m blk
cdbBlocksToAdd :: BlocksToAdd m blk
cdbBlocksToAdd } =
    Tracer m (TraceAddBlockEvent blk)
-> BlocksToAdd m blk -> blk -> m (AddBlockPromise m blk)
forall (m :: * -> *) blk.
(IOLike m, HasHeader blk) =>
Tracer m (TraceAddBlockEvent blk)
-> BlocksToAdd m blk -> blk -> m (AddBlockPromise m blk)
addBlockToAdd ((TraceAddBlockEvent blk -> TraceEvent blk)
-> Tracer m (TraceEvent blk) -> Tracer m (TraceAddBlockEvent blk)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap TraceAddBlockEvent blk -> TraceEvent blk
forall blk. TraceAddBlockEvent blk -> TraceEvent blk
TraceAddBlockEvent Tracer m (TraceEvent blk)
cdbTracer) BlocksToAdd m blk
cdbBlocksToAdd

-- | Add a block to the ChainDB, /synchronously/.
--
-- This is the only operation that actually changes the ChainDB. It will store
-- the block on disk and trigger chain selection, possibly switching to a
-- fork.
--
-- When the slot of the block is > the current slot, a chain selection will be
-- scheduled in the slot of the block.
addBlockSync
  :: forall m blk.
     ( IOLike m
     , GetPrevHash blk
     , LedgerSupportsProtocol blk
     , InspectLedger blk
     , HasHardForkHistory blk
     , HasCallStack
     )
  => ChainDbEnv m blk
  -> BlockToAdd m blk
  -> m ()
addBlockSync :: ChainDbEnv m blk -> BlockToAdd m blk -> m ()
addBlockSync cdb :: ChainDbEnv m blk
cdb@CDB {Tracer m (LedgerDB' blk)
Tracer m (TraceEvent blk)
StrictTVar m (m ())
StrictTVar m (FutureBlocks blk)
StrictTVar m (Map ReaderKey (ReaderHandle m blk))
StrictTVar m (Map IteratorKey (m ()))
StrictTVar m (AnchoredFragment (Header blk))
StrictTVar m (WithFingerprint (InvalidBlocks blk))
StrictTVar m ReaderKey
StrictTVar m IteratorKey
DiffTime
TopLevelConfig blk
StrictMVar m ()
VolatileDB m blk
ChunkInfo
ResourceRegistry m
ImmutableDB m blk
LgrDB m blk
CheckInFuture m blk
BlocksToAdd m blk
blk -> Bool
cdbFutureBlocks :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m (FutureBlocks blk)
cdbCheckInFuture :: forall (m :: * -> *) blk. ChainDbEnv m blk -> CheckInFuture m blk
cdbCheckIntegrity :: forall (m :: * -> *) blk. ChainDbEnv m blk -> blk -> Bool
cdbChunkInfo :: forall (m :: * -> *) blk. ChainDbEnv m blk -> ChunkInfo
cdbKillBgThreads :: forall (m :: * -> *) blk. ChainDbEnv m blk -> StrictTVar m (m ())
cdbGcInterval :: forall (m :: * -> *) blk. ChainDbEnv m blk -> DiffTime
cdbGcDelay :: forall (m :: * -> *) blk. ChainDbEnv m blk -> DiffTime
cdbRegistry :: forall (m :: * -> *) blk. ChainDbEnv m blk -> ResourceRegistry m
cdbTraceLedger :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> Tracer m (LedgerDB' blk)
cdbCopyLock :: forall (m :: * -> *) blk. ChainDbEnv m blk -> StrictMVar m ()
cdbNextReaderKey :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m ReaderKey
cdbNextIteratorKey :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m IteratorKey
cdbInvalid :: forall (m :: * -> *) blk.
ChainDbEnv m blk
-> StrictTVar m (WithFingerprint (InvalidBlocks blk))
cdbTopLevelConfig :: forall (m :: * -> *) blk. ChainDbEnv m blk -> TopLevelConfig blk
cdbReaders :: forall (m :: * -> *) blk.
ChainDbEnv m blk
-> StrictTVar m (Map ReaderKey (ReaderHandle m blk))
cdbIterators :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m (Map IteratorKey (m ()))
cdbChain :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m (AnchoredFragment (Header blk))
cdbLgrDB :: forall (m :: * -> *) blk. ChainDbEnv m blk -> LgrDB m blk
cdbVolatileDB :: forall (m :: * -> *) blk. ChainDbEnv m blk -> VolatileDB m blk
cdbImmutableDB :: forall (m :: * -> *) blk. ChainDbEnv m blk -> ImmutableDB m blk
cdbFutureBlocks :: StrictTVar m (FutureBlocks blk)
cdbBlocksToAdd :: BlocksToAdd m blk
cdbCheckInFuture :: CheckInFuture m blk
cdbCheckIntegrity :: blk -> Bool
cdbChunkInfo :: ChunkInfo
cdbKillBgThreads :: StrictTVar m (m ())
cdbGcInterval :: DiffTime
cdbGcDelay :: DiffTime
cdbRegistry :: ResourceRegistry m
cdbTraceLedger :: Tracer m (LedgerDB' blk)
cdbTracer :: Tracer m (TraceEvent blk)
cdbCopyLock :: StrictMVar m ()
cdbNextReaderKey :: StrictTVar m ReaderKey
cdbNextIteratorKey :: StrictTVar m IteratorKey
cdbInvalid :: StrictTVar m (WithFingerprint (InvalidBlocks blk))
cdbTopLevelConfig :: TopLevelConfig blk
cdbReaders :: StrictTVar m (Map ReaderKey (ReaderHandle m blk))
cdbIterators :: StrictTVar m (Map IteratorKey (m ()))
cdbChain :: StrictTVar m (AnchoredFragment (Header blk))
cdbLgrDB :: LgrDB m blk
cdbVolatileDB :: VolatileDB m blk
cdbImmutableDB :: ImmutableDB m blk
cdbBlocksToAdd :: forall (m :: * -> *) blk. ChainDbEnv m blk -> BlocksToAdd m blk
cdbTracer :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> Tracer m (TraceEvent blk)
..} BlockToAdd { blockToAdd :: forall (m :: * -> *) blk. BlockToAdd m blk -> blk
blockToAdd = blk
b, StrictTMVar m Bool
StrictTMVar m (Point blk)
varBlockProcessed :: forall (m :: * -> *) blk.
BlockToAdd m blk -> StrictTMVar m (Point blk)
varBlockWrittenToDisk :: forall (m :: * -> *) blk. BlockToAdd m blk -> StrictTMVar m Bool
varBlockProcessed :: StrictTMVar m (Point blk)
varBlockWrittenToDisk :: StrictTMVar m Bool
.. } = do
    (HeaderHash blk -> Bool
isMember, InvalidBlocks blk
invalid, AnchoredFragment (Header blk)
curChain) <- STM
  m
  (HeaderHash blk -> Bool, InvalidBlocks blk,
   AnchoredFragment (Header blk))
-> m (HeaderHash blk -> Bool, InvalidBlocks blk,
      AnchoredFragment (Header blk))
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM
   m
   (HeaderHash blk -> Bool, InvalidBlocks blk,
    AnchoredFragment (Header blk))
 -> m (HeaderHash blk -> Bool, InvalidBlocks blk,
       AnchoredFragment (Header blk)))
-> STM
     m
     (HeaderHash blk -> Bool, InvalidBlocks blk,
      AnchoredFragment (Header blk))
-> m (HeaderHash blk -> Bool, InvalidBlocks blk,
      AnchoredFragment (Header blk))
forall a b. (a -> b) -> a -> b
$ (,,)
      ((HeaderHash blk -> Bool)
 -> InvalidBlocks blk
 -> AnchoredFragment (Header blk)
 -> (HeaderHash blk -> Bool, InvalidBlocks blk,
     AnchoredFragment (Header blk)))
-> STM m (HeaderHash blk -> Bool)
-> STM
     m
     (InvalidBlocks blk
      -> AnchoredFragment (Header blk)
      -> (HeaderHash blk -> Bool, InvalidBlocks blk,
          AnchoredFragment (Header blk)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VolatileDB m blk -> STM m (HeaderHash blk -> Bool)
forall (m :: * -> *) blk.
Functor (STM m) =>
VolatileDB m blk -> STM m (HeaderHash blk -> Bool)
VolatileDB.getIsMember          VolatileDB m blk
cdbVolatileDB
      STM
  m
  (InvalidBlocks blk
   -> AnchoredFragment (Header blk)
   -> (HeaderHash blk -> Bool, InvalidBlocks blk,
       AnchoredFragment (Header blk)))
-> STM m (InvalidBlocks blk)
-> STM
     m
     (AnchoredFragment (Header blk)
      -> (HeaderHash blk -> Bool, InvalidBlocks blk,
          AnchoredFragment (Header blk)))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (WithFingerprint (InvalidBlocks blk) -> InvalidBlocks blk
forall a. WithFingerprint a -> a
forgetFingerprint (WithFingerprint (InvalidBlocks blk) -> InvalidBlocks blk)
-> STM m (WithFingerprint (InvalidBlocks blk))
-> STM m (InvalidBlocks blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m (WithFingerprint (InvalidBlocks blk))
-> STM m (WithFingerprint (InvalidBlocks blk))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (WithFingerprint (InvalidBlocks blk))
cdbInvalid)
      STM
  m
  (AnchoredFragment (Header blk)
   -> (HeaderHash blk -> Bool, InvalidBlocks blk,
       AnchoredFragment (Header blk)))
-> STM m (AnchoredFragment (Header blk))
-> STM
     m
     (HeaderHash blk -> Bool, InvalidBlocks blk,
      AnchoredFragment (Header blk))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ChainDbEnv m blk -> STM m (AnchoredFragment (Header blk))
forall (m :: * -> *) blk.
(IOLike m, HasHeader (Header blk),
 ConsensusProtocol (BlockProtocol blk)) =>
ChainDbEnv m blk -> STM m (AnchoredFragment (Header blk))
Query.getCurrentChain           ChainDbEnv m blk
cdb

    let immBlockNo :: WithOrigin BlockNo
immBlockNo = AnchoredFragment (Header blk) -> WithOrigin BlockNo
forall block. AnchoredFragment block -> WithOrigin BlockNo
AF.anchorBlockNo AnchoredFragment (Header blk)
curChain

    -- We follow the steps from section "## Adding a block" in ChainDB.md

    -- Note: we call 'chainSelectionForFutureBlocks' in all branches instead
    -- of once, before branching, because we want to do it /after/ writing the
    -- block to the VolatileDB and delivering the 'varBlockWrittenToDisk'
    -- promise, as this is the promise the BlockFetch client waits for.
    -- Otherwise, the BlockFetch client would have to wait for
    -- 'chainSelectionForFutureBlocks'.

    -- ### Ignore
    Point blk
newTip <- if
      | Header blk -> IsEBB -> WithOrigin BlockNo -> Bool
forall blk.
HasHeader (Header blk) =>
Header blk -> IsEBB -> WithOrigin BlockNo -> Bool
olderThanK Header blk
hdr IsEBB
isEBB WithOrigin BlockNo
immBlockNo -> do
        TraceAddBlockEvent blk -> m ()
trace (TraceAddBlockEvent blk -> m ()) -> TraceAddBlockEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$ RealPoint blk -> TraceAddBlockEvent blk
forall blk. RealPoint blk -> TraceAddBlockEvent blk
IgnoreBlockOlderThanK (blk -> RealPoint blk
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint blk
b)
        Bool -> m ()
deliverWrittenToDisk Bool
False
        ChainDbEnv m blk -> BlockCache blk -> m (Point blk)
forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsProtocol blk, InspectLedger blk,
 HasHardForkHistory blk, HasCallStack) =>
ChainDbEnv m blk -> BlockCache blk -> m (Point blk)
chainSelectionForFutureBlocks ChainDbEnv m blk
cdb BlockCache blk
forall blk. BlockCache blk
BlockCache.empty

      | HeaderHash blk -> Bool
isMember (blk -> HeaderHash blk
forall b. HasHeader b => b -> HeaderHash b
blockHash blk
b) -> do
        TraceAddBlockEvent blk -> m ()
trace (TraceAddBlockEvent blk -> m ()) -> TraceAddBlockEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$ RealPoint blk -> TraceAddBlockEvent blk
forall blk. RealPoint blk -> TraceAddBlockEvent blk
IgnoreBlockAlreadyInVolatileDB (blk -> RealPoint blk
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint blk
b)
        Bool -> m ()
deliverWrittenToDisk Bool
True
        ChainDbEnv m blk -> BlockCache blk -> m (Point blk)
forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsProtocol blk, InspectLedger blk,
 HasHardForkHistory blk, HasCallStack) =>
ChainDbEnv m blk -> BlockCache blk -> m (Point blk)
chainSelectionForFutureBlocks ChainDbEnv m blk
cdb BlockCache blk
forall blk. BlockCache blk
BlockCache.empty

      | Just (InvalidBlockInfo InvalidBlockReason blk
reason SlotNo
_) <- HeaderHash blk -> InvalidBlocks blk -> Maybe (InvalidBlockInfo blk)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (blk -> HeaderHash blk
forall b. HasHeader b => b -> HeaderHash b
blockHash blk
b) InvalidBlocks blk
invalid -> do
        TraceAddBlockEvent blk -> m ()
trace (TraceAddBlockEvent blk -> m ()) -> TraceAddBlockEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$ RealPoint blk -> InvalidBlockReason blk -> TraceAddBlockEvent blk
forall blk.
RealPoint blk -> InvalidBlockReason blk -> TraceAddBlockEvent blk
IgnoreInvalidBlock (blk -> RealPoint blk
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint blk
b) InvalidBlockReason blk
reason
        Bool -> m ()
deliverWrittenToDisk Bool
False
        ChainDbEnv m blk -> BlockCache blk -> m (Point blk)
forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsProtocol blk, InspectLedger blk,
 HasHardForkHistory blk, HasCallStack) =>
ChainDbEnv m blk -> BlockCache blk -> m (Point blk)
chainSelectionForFutureBlocks ChainDbEnv m blk
cdb BlockCache blk
forall blk. BlockCache blk
BlockCache.empty

      -- The remaining cases
      | Bool
otherwise -> do
        VolatileDB m blk -> blk -> m ()
forall (m :: * -> *) blk.
VolatileDB m blk -> HasCallStack => blk -> m ()
VolatileDB.putBlock VolatileDB m blk
cdbVolatileDB blk
b
        TraceAddBlockEvent blk -> m ()
trace (TraceAddBlockEvent blk -> m ()) -> TraceAddBlockEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$ RealPoint blk -> BlockNo -> IsEBB -> TraceAddBlockEvent blk
forall blk.
RealPoint blk -> BlockNo -> IsEBB -> TraceAddBlockEvent blk
AddedBlockToVolatileDB (blk -> RealPoint blk
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint blk
b) (blk -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo blk
b) IsEBB
isEBB
        Bool -> m ()
deliverWrittenToDisk Bool
True

        let blockCache :: BlockCache blk
blockCache = blk -> BlockCache blk
forall blk. HasHeader blk => blk -> BlockCache blk
BlockCache.singleton blk
b
        -- Do chain selection for future blocks before chain selection for the
        -- new block. When some future blocks are now older than the current
        -- block, we will do chain selection in a more chronological order.
        m (Point blk) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Point blk) -> m ()) -> m (Point blk) -> m ()
forall a b. (a -> b) -> a -> b
$ ChainDbEnv m blk -> BlockCache blk -> m (Point blk)
forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsProtocol blk, InspectLedger blk,
 HasHardForkHistory blk, HasCallStack) =>
ChainDbEnv m blk -> BlockCache blk -> m (Point blk)
chainSelectionForFutureBlocks ChainDbEnv m blk
cdb BlockCache blk
blockCache
        ChainDbEnv m blk -> BlockCache blk -> Header blk -> m (Point blk)
forall (m :: * -> *) blk.
(IOLike m, HasHeader blk, LedgerSupportsProtocol blk,
 InspectLedger blk, HasHardForkHistory blk, HasCallStack) =>
ChainDbEnv m blk -> BlockCache blk -> Header blk -> m (Point blk)
chainSelectionForBlock ChainDbEnv m blk
cdb BlockCache blk
blockCache Header blk
hdr

    Point blk -> m ()
deliverProcessed Point blk
newTip
  where
    trace :: TraceAddBlockEvent blk -> m ()
    trace :: TraceAddBlockEvent blk -> m ()
trace = Tracer m (TraceAddBlockEvent blk) -> TraceAddBlockEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith ((TraceAddBlockEvent blk -> TraceEvent blk)
-> Tracer m (TraceEvent blk) -> Tracer m (TraceAddBlockEvent blk)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap TraceAddBlockEvent blk -> TraceEvent blk
forall blk. TraceAddBlockEvent blk -> TraceEvent blk
TraceAddBlockEvent Tracer m (TraceEvent blk)
cdbTracer)

    hdr :: Header blk
    hdr :: Header blk
hdr = blk -> Header blk
forall blk. GetHeader blk => blk -> Header blk
getHeader blk
b

    isEBB :: IsEBB
    isEBB :: IsEBB
isEBB = Header blk -> IsEBB
forall blk. GetHeader blk => Header blk -> IsEBB
headerToIsEBB Header blk
hdr

    -- | Fill in the 'TMVar' for the 'varBlockWrittenToDisk' of the block's
    -- 'AddBlockPromise' with the given 'Bool'.
    deliverWrittenToDisk :: Bool -> m ()
    deliverWrittenToDisk :: Bool -> m ()
deliverWrittenToDisk Bool
writtenToDisk = STM m () -> m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$
        StrictTMVar m Bool -> Bool -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTMVar m a -> a -> STM m ()
putTMVar StrictTMVar m Bool
varBlockWrittenToDisk Bool
writtenToDisk

    -- | Fill in the 'TMVar' for the 'varBlockProcessed' of the block's
    -- 'AddBlockPromise' with the given tip.
    deliverProcessed :: Point blk -> m ()
    deliverProcessed :: Point blk -> m ()
deliverProcessed Point blk
tip = STM m () -> m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$
        StrictTMVar m (Point blk) -> Point blk -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTMVar m a -> a -> STM m ()
putTMVar StrictTMVar m (Point blk)
varBlockProcessed Point blk
tip

-- | Return 'True' when the given header should be ignored when adding it
-- because it is too old, i.e., we wouldn't be able to switch to a chain
-- containing the corresponding block because its block number is more than
-- @k@ blocks or exactly @k@ blocks back.
--
-- Special case: the header corresponds to an EBB which has the same block
-- number as the block @k@ blocks back (the most recent \"immutable\" block).
-- As EBBs share their block number with the block before them, the EBB is not
-- too old in that case and can be adopted as part of our chain.
--
-- This special case can occur, for example, when the VolatileDB is empty
-- (because of corruption). The \"immutable\" block is then also the tip of
-- the chain. If we then try to add the EBB after it, it will have the same
-- block number, so we must allow it.
olderThanK
  :: HasHeader (Header blk)
  => Header blk
     -- ^ Header of the block to add
  -> IsEBB
     -- ^ Whether the block is an EBB or not
  -> WithOrigin BlockNo
     -- ^ The block number of the most recent \"immutable\" block, i.e., the
     -- block @k@ blocks back.
  -> Bool
olderThanK :: Header blk -> IsEBB -> WithOrigin BlockNo -> Bool
olderThanK Header blk
hdr IsEBB
isEBB WithOrigin BlockNo
immBlockNo
    | BlockNo -> WithOrigin BlockNo
forall t. t -> WithOrigin t
NotOrigin BlockNo
bNo WithOrigin BlockNo -> WithOrigin BlockNo -> Bool
forall a. Eq a => a -> a -> Bool
== WithOrigin BlockNo
immBlockNo
    , IsEBB
isEBB IsEBB -> IsEBB -> Bool
forall a. Eq a => a -> a -> Bool
== IsEBB
IsEBB
    = Bool
False
    | Bool
otherwise
    = BlockNo -> WithOrigin BlockNo
forall t. t -> WithOrigin t
NotOrigin BlockNo
bNo WithOrigin BlockNo -> WithOrigin BlockNo -> Bool
forall a. Ord a => a -> a -> Bool
<= WithOrigin BlockNo
immBlockNo
  where
    bNo :: BlockNo
bNo = Header blk -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo Header blk
hdr

-- | Return the new tip.
chainSelectionForFutureBlocks
  :: ( IOLike m
     , LedgerSupportsProtocol blk
     , InspectLedger blk
     , HasHardForkHistory blk
     , HasCallStack
     )
  => ChainDbEnv m blk -> BlockCache blk -> m (Point blk)
chainSelectionForFutureBlocks :: ChainDbEnv m blk -> BlockCache blk -> m (Point blk)
chainSelectionForFutureBlocks cdb :: ChainDbEnv m blk
cdb@CDB{Tracer m (LedgerDB' blk)
Tracer m (TraceEvent blk)
StrictTVar m (m ())
StrictTVar m (FutureBlocks blk)
StrictTVar m (Map ReaderKey (ReaderHandle m blk))
StrictTVar m (Map IteratorKey (m ()))
StrictTVar m (AnchoredFragment (Header blk))
StrictTVar m (WithFingerprint (InvalidBlocks blk))
StrictTVar m ReaderKey
StrictTVar m IteratorKey
DiffTime
TopLevelConfig blk
StrictMVar m ()
VolatileDB m blk
ChunkInfo
ResourceRegistry m
ImmutableDB m blk
LgrDB m blk
CheckInFuture m blk
BlocksToAdd m blk
blk -> Bool
cdbFutureBlocks :: StrictTVar m (FutureBlocks blk)
cdbBlocksToAdd :: BlocksToAdd m blk
cdbCheckInFuture :: CheckInFuture m blk
cdbCheckIntegrity :: blk -> Bool
cdbChunkInfo :: ChunkInfo
cdbKillBgThreads :: StrictTVar m (m ())
cdbGcInterval :: DiffTime
cdbGcDelay :: DiffTime
cdbRegistry :: ResourceRegistry m
cdbTraceLedger :: Tracer m (LedgerDB' blk)
cdbTracer :: Tracer m (TraceEvent blk)
cdbCopyLock :: StrictMVar m ()
cdbNextReaderKey :: StrictTVar m ReaderKey
cdbNextIteratorKey :: StrictTVar m IteratorKey
cdbInvalid :: StrictTVar m (WithFingerprint (InvalidBlocks blk))
cdbTopLevelConfig :: TopLevelConfig blk
cdbReaders :: StrictTVar m (Map ReaderKey (ReaderHandle m blk))
cdbIterators :: StrictTVar m (Map IteratorKey (m ()))
cdbChain :: StrictTVar m (AnchoredFragment (Header blk))
cdbLgrDB :: LgrDB m blk
cdbVolatileDB :: VolatileDB m blk
cdbImmutableDB :: ImmutableDB m blk
cdbFutureBlocks :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m (FutureBlocks blk)
cdbCheckInFuture :: forall (m :: * -> *) blk. ChainDbEnv m blk -> CheckInFuture m blk
cdbCheckIntegrity :: forall (m :: * -> *) blk. ChainDbEnv m blk -> blk -> Bool
cdbChunkInfo :: forall (m :: * -> *) blk. ChainDbEnv m blk -> ChunkInfo
cdbKillBgThreads :: forall (m :: * -> *) blk. ChainDbEnv m blk -> StrictTVar m (m ())
cdbGcInterval :: forall (m :: * -> *) blk. ChainDbEnv m blk -> DiffTime
cdbGcDelay :: forall (m :: * -> *) blk. ChainDbEnv m blk -> DiffTime
cdbRegistry :: forall (m :: * -> *) blk. ChainDbEnv m blk -> ResourceRegistry m
cdbTraceLedger :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> Tracer m (LedgerDB' blk)
cdbCopyLock :: forall (m :: * -> *) blk. ChainDbEnv m blk -> StrictMVar m ()
cdbNextReaderKey :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m ReaderKey
cdbNextIteratorKey :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m IteratorKey
cdbInvalid :: forall (m :: * -> *) blk.
ChainDbEnv m blk
-> StrictTVar m (WithFingerprint (InvalidBlocks blk))
cdbTopLevelConfig :: forall (m :: * -> *) blk. ChainDbEnv m blk -> TopLevelConfig blk
cdbReaders :: forall (m :: * -> *) blk.
ChainDbEnv m blk
-> StrictTVar m (Map ReaderKey (ReaderHandle m blk))
cdbIterators :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m (Map IteratorKey (m ()))
cdbChain :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m (AnchoredFragment (Header blk))
cdbLgrDB :: forall (m :: * -> *) blk. ChainDbEnv m blk -> LgrDB m blk
cdbVolatileDB :: forall (m :: * -> *) blk. ChainDbEnv m blk -> VolatileDB m blk
cdbImmutableDB :: forall (m :: * -> *) blk. ChainDbEnv m blk -> ImmutableDB m blk
cdbBlocksToAdd :: forall (m :: * -> *) blk. ChainDbEnv m blk -> BlocksToAdd m blk
cdbTracer :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> Tracer m (TraceEvent blk)
..} BlockCache blk
blockCache = do
    -- Get 'cdbFutureBlocks' and empty the map in the TVar. It will be
    -- repopulated with the blocks that are still from the future (but not the
    -- ones no longer from the future) during chain selection for those
    -- blocks.
    [Header blk]
futureBlockHeaders <- STM m [Header blk] -> m [Header blk]
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m [Header blk] -> m [Header blk])
-> STM m [Header blk] -> m [Header blk]
forall a b. (a -> b) -> a -> b
$ do
      FutureBlocks blk
futureBlocks <- StrictTVar m (FutureBlocks blk) -> STM m (FutureBlocks blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (FutureBlocks blk)
cdbFutureBlocks
      StrictTVar m (FutureBlocks blk) -> FutureBlocks blk -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (FutureBlocks blk)
cdbFutureBlocks FutureBlocks blk
forall k a. Map k a
Map.empty
      [Header blk] -> STM m [Header blk]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Header blk] -> STM m [Header blk])
-> [Header blk] -> STM m [Header blk]
forall a b. (a -> b) -> a -> b
$ FutureBlocks blk -> [Header blk]
forall k a. Map k a -> [a]
Map.elems FutureBlocks blk
futureBlocks
    [Header blk] -> (Header blk -> m (Point blk)) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Header blk]
futureBlockHeaders ((Header blk -> m (Point blk)) -> m ())
-> (Header blk -> m (Point blk)) -> m ()
forall a b. (a -> b) -> a -> b
$ \Header blk
hdr -> do
      TraceAddBlockEvent blk -> m ()
trace (TraceAddBlockEvent blk -> m ()) -> TraceAddBlockEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$ RealPoint blk -> TraceAddBlockEvent blk
forall blk. RealPoint blk -> TraceAddBlockEvent blk
ChainSelectionForFutureBlock (Header blk -> RealPoint blk
forall blk. HasHeader (Header blk) => Header blk -> RealPoint blk
headerRealPoint Header blk
hdr)
      ChainDbEnv m blk -> BlockCache blk -> Header blk -> m (Point blk)
forall (m :: * -> *) blk.
(IOLike m, HasHeader blk, LedgerSupportsProtocol blk,
 InspectLedger blk, HasHardForkHistory blk, HasCallStack) =>
ChainDbEnv m blk -> BlockCache blk -> Header blk -> m (Point blk)
chainSelectionForBlock ChainDbEnv m blk
cdb BlockCache blk
blockCache Header blk
hdr
    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
$ ChainDbEnv m blk -> STM m (Point blk)
forall (m :: * -> *) blk.
(IOLike m, HasHeader (Header blk)) =>
ChainDbEnv m blk -> STM m (Point blk)
Query.getTipPoint ChainDbEnv m blk
cdb
  where
    trace :: TraceAddBlockEvent blk -> m ()
trace = Tracer m (TraceAddBlockEvent blk) -> TraceAddBlockEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith ((TraceAddBlockEvent blk -> TraceEvent blk)
-> Tracer m (TraceEvent blk) -> Tracer m (TraceAddBlockEvent blk)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap TraceAddBlockEvent blk -> TraceEvent blk
forall blk. TraceAddBlockEvent blk -> TraceEvent blk
TraceAddBlockEvent Tracer m (TraceEvent blk)
cdbTracer)

-- | Trigger chain selection for the given block.
--
-- PRECONDITION: the block is in the VolatileDB.
--
-- PRECONDITION: the slot of the block <= the current (wall) slot
--
-- The new tip of the current chain is returned.
--
-- = Constructing candidate fragments
--
-- The VolatileDB keeps a \"successors\" map in memory, telling us the hashes
-- of the known successors of any block, but it does not keep /headers/ in
-- memory, which are needed to construct candidate fargments. We try to reuse
-- the headers from the current chain fragment where possible, but it will not
-- contain all needed headers. This means that we will need to read some
-- blocks from disk and extract their headers. Under normal circumstances this
-- does not matter too much; although this will be done every time we add a
-- block, the expected number of headers to read from disk is very small:
--
-- * None if we stay on the current chain and this is just the next block
-- * A handful if we stay on the current chain and the block we just received
--   was a missing block and we already received some of its successors
-- * A handful if we switch to a short fork
--
-- This is expensive only
--
-- * on startup: in this case we need to read at least @k@ blocks from the
--   VolatileDB, and possibly more if there are some other chains in the
--   VolatileDB starting from the tip of the ImmutableDB
-- * when we switch to a distant fork
--
-- This cost is currently deemed acceptable.
chainSelectionForBlock
  :: forall m blk.
     ( IOLike m
     , HasHeader blk
     , LedgerSupportsProtocol blk
     , InspectLedger blk
     , HasHardForkHistory blk
     , HasCallStack
     )
  => ChainDbEnv m blk
  -> BlockCache blk
  -> Header blk
  -> m (Point blk)
chainSelectionForBlock :: ChainDbEnv m blk -> BlockCache blk -> Header blk -> m (Point blk)
chainSelectionForBlock cdb :: ChainDbEnv m blk
cdb@CDB{Tracer m (LedgerDB' blk)
Tracer m (TraceEvent blk)
StrictTVar m (m ())
StrictTVar m (FutureBlocks blk)
StrictTVar m (Map ReaderKey (ReaderHandle m blk))
StrictTVar m (Map IteratorKey (m ()))
StrictTVar m (AnchoredFragment (Header blk))
StrictTVar m (WithFingerprint (InvalidBlocks blk))
StrictTVar m ReaderKey
StrictTVar m IteratorKey
DiffTime
TopLevelConfig blk
StrictMVar m ()
VolatileDB m blk
ChunkInfo
ResourceRegistry m
ImmutableDB m blk
LgrDB m blk
CheckInFuture m blk
BlocksToAdd m blk
blk -> Bool
cdbFutureBlocks :: StrictTVar m (FutureBlocks blk)
cdbBlocksToAdd :: BlocksToAdd m blk
cdbCheckInFuture :: CheckInFuture m blk
cdbCheckIntegrity :: blk -> Bool
cdbChunkInfo :: ChunkInfo
cdbKillBgThreads :: StrictTVar m (m ())
cdbGcInterval :: DiffTime
cdbGcDelay :: DiffTime
cdbRegistry :: ResourceRegistry m
cdbTraceLedger :: Tracer m (LedgerDB' blk)
cdbTracer :: Tracer m (TraceEvent blk)
cdbCopyLock :: StrictMVar m ()
cdbNextReaderKey :: StrictTVar m ReaderKey
cdbNextIteratorKey :: StrictTVar m IteratorKey
cdbInvalid :: StrictTVar m (WithFingerprint (InvalidBlocks blk))
cdbTopLevelConfig :: TopLevelConfig blk
cdbReaders :: StrictTVar m (Map ReaderKey (ReaderHandle m blk))
cdbIterators :: StrictTVar m (Map IteratorKey (m ()))
cdbChain :: StrictTVar m (AnchoredFragment (Header blk))
cdbLgrDB :: LgrDB m blk
cdbVolatileDB :: VolatileDB m blk
cdbImmutableDB :: ImmutableDB m blk
cdbFutureBlocks :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m (FutureBlocks blk)
cdbCheckInFuture :: forall (m :: * -> *) blk. ChainDbEnv m blk -> CheckInFuture m blk
cdbCheckIntegrity :: forall (m :: * -> *) blk. ChainDbEnv m blk -> blk -> Bool
cdbChunkInfo :: forall (m :: * -> *) blk. ChainDbEnv m blk -> ChunkInfo
cdbKillBgThreads :: forall (m :: * -> *) blk. ChainDbEnv m blk -> StrictTVar m (m ())
cdbGcInterval :: forall (m :: * -> *) blk. ChainDbEnv m blk -> DiffTime
cdbGcDelay :: forall (m :: * -> *) blk. ChainDbEnv m blk -> DiffTime
cdbRegistry :: forall (m :: * -> *) blk. ChainDbEnv m blk -> ResourceRegistry m
cdbTraceLedger :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> Tracer m (LedgerDB' blk)
cdbCopyLock :: forall (m :: * -> *) blk. ChainDbEnv m blk -> StrictMVar m ()
cdbNextReaderKey :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m ReaderKey
cdbNextIteratorKey :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m IteratorKey
cdbInvalid :: forall (m :: * -> *) blk.
ChainDbEnv m blk
-> StrictTVar m (WithFingerprint (InvalidBlocks blk))
cdbTopLevelConfig :: forall (m :: * -> *) blk. ChainDbEnv m blk -> TopLevelConfig blk
cdbReaders :: forall (m :: * -> *) blk.
ChainDbEnv m blk
-> StrictTVar m (Map ReaderKey (ReaderHandle m blk))
cdbIterators :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m (Map IteratorKey (m ()))
cdbChain :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m (AnchoredFragment (Header blk))
cdbLgrDB :: forall (m :: * -> *) blk. ChainDbEnv m blk -> LgrDB m blk
cdbVolatileDB :: forall (m :: * -> *) blk. ChainDbEnv m blk -> VolatileDB m blk
cdbImmutableDB :: forall (m :: * -> *) blk. ChainDbEnv m blk -> ImmutableDB m blk
cdbBlocksToAdd :: forall (m :: * -> *) blk. ChainDbEnv m blk -> BlocksToAdd m blk
cdbTracer :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> Tracer m (TraceEvent blk)
..} BlockCache blk
blockCache Header blk
hdr = do
    (InvalidBlocks blk
invalid, ChainHash blk -> Set (HeaderHash blk)
succsOf, HeaderHash blk -> Maybe (BlockInfo blk)
lookupBlockInfo, AnchoredFragment (Header blk)
curChain, Point blk
tipPoint, LedgerDB' blk
ledgerDB)
      <- STM
  m
  (InvalidBlocks blk, ChainHash blk -> Set (HeaderHash blk),
   HeaderHash blk -> Maybe (BlockInfo blk),
   AnchoredFragment (Header blk), Point blk, LedgerDB' blk)
-> m (InvalidBlocks blk, ChainHash blk -> Set (HeaderHash blk),
      HeaderHash blk -> Maybe (BlockInfo blk),
      AnchoredFragment (Header blk), Point blk, LedgerDB' blk)
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM
   m
   (InvalidBlocks blk, ChainHash blk -> Set (HeaderHash blk),
    HeaderHash blk -> Maybe (BlockInfo blk),
    AnchoredFragment (Header blk), Point blk, LedgerDB' blk)
 -> m (InvalidBlocks blk, ChainHash blk -> Set (HeaderHash blk),
       HeaderHash blk -> Maybe (BlockInfo blk),
       AnchoredFragment (Header blk), Point blk, LedgerDB' blk))
-> STM
     m
     (InvalidBlocks blk, ChainHash blk -> Set (HeaderHash blk),
      HeaderHash blk -> Maybe (BlockInfo blk),
      AnchoredFragment (Header blk), Point blk, LedgerDB' blk)
-> m (InvalidBlocks blk, ChainHash blk -> Set (HeaderHash blk),
      HeaderHash blk -> Maybe (BlockInfo blk),
      AnchoredFragment (Header blk), Point blk, LedgerDB' blk)
forall a b. (a -> b) -> a -> b
$ (,,,,,)
          (InvalidBlocks blk
 -> (ChainHash blk -> Set (HeaderHash blk))
 -> (HeaderHash blk -> Maybe (BlockInfo blk))
 -> AnchoredFragment (Header blk)
 -> Point blk
 -> LedgerDB' blk
 -> (InvalidBlocks blk, ChainHash blk -> Set (HeaderHash blk),
     HeaderHash blk -> Maybe (BlockInfo blk),
     AnchoredFragment (Header blk), Point blk, LedgerDB' blk))
-> STM m (InvalidBlocks blk)
-> STM
     m
     ((ChainHash blk -> Set (HeaderHash blk))
      -> (HeaderHash blk -> Maybe (BlockInfo blk))
      -> AnchoredFragment (Header blk)
      -> Point blk
      -> LedgerDB' blk
      -> (InvalidBlocks blk, ChainHash blk -> Set (HeaderHash blk),
          HeaderHash blk -> Maybe (BlockInfo blk),
          AnchoredFragment (Header blk), Point blk, LedgerDB' blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (WithFingerprint (InvalidBlocks blk) -> InvalidBlocks blk
forall a. WithFingerprint a -> a
forgetFingerprint (WithFingerprint (InvalidBlocks blk) -> InvalidBlocks blk)
-> STM m (WithFingerprint (InvalidBlocks blk))
-> STM m (InvalidBlocks blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m (WithFingerprint (InvalidBlocks blk))
-> STM m (WithFingerprint (InvalidBlocks blk))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (WithFingerprint (InvalidBlocks blk))
cdbInvalid)
          STM
  m
  ((ChainHash blk -> Set (HeaderHash blk))
   -> (HeaderHash blk -> Maybe (BlockInfo blk))
   -> AnchoredFragment (Header blk)
   -> Point blk
   -> LedgerDB' blk
   -> (InvalidBlocks blk, ChainHash blk -> Set (HeaderHash blk),
       HeaderHash blk -> Maybe (BlockInfo blk),
       AnchoredFragment (Header blk), Point blk, LedgerDB' blk))
-> STM m (ChainHash blk -> Set (HeaderHash blk))
-> STM
     m
     ((HeaderHash blk -> Maybe (BlockInfo blk))
      -> AnchoredFragment (Header blk)
      -> Point blk
      -> LedgerDB' blk
      -> (InvalidBlocks blk, ChainHash blk -> Set (HeaderHash blk),
          HeaderHash blk -> Maybe (BlockInfo blk),
          AnchoredFragment (Header blk), Point blk, LedgerDB' blk))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> VolatileDB m blk
-> HasCallStack => STM m (ChainHash blk -> Set (HeaderHash blk))
forall (m :: * -> *) blk.
VolatileDB m blk
-> HasCallStack => STM m (ChainHash blk -> Set (HeaderHash blk))
VolatileDB.filterByPredecessor  VolatileDB m blk
cdbVolatileDB
          STM
  m
  ((HeaderHash blk -> Maybe (BlockInfo blk))
   -> AnchoredFragment (Header blk)
   -> Point blk
   -> LedgerDB' blk
   -> (InvalidBlocks blk, ChainHash blk -> Set (HeaderHash blk),
       HeaderHash blk -> Maybe (BlockInfo blk),
       AnchoredFragment (Header blk), Point blk, LedgerDB' blk))
-> STM m (HeaderHash blk -> Maybe (BlockInfo blk))
-> STM
     m
     (AnchoredFragment (Header blk)
      -> Point blk
      -> LedgerDB' blk
      -> (InvalidBlocks blk, ChainHash blk -> Set (HeaderHash blk),
          HeaderHash blk -> Maybe (BlockInfo blk),
          AnchoredFragment (Header blk), Point blk, LedgerDB' blk))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> VolatileDB m blk
-> HasCallStack => STM m (HeaderHash blk -> Maybe (BlockInfo blk))
forall (m :: * -> *) blk.
VolatileDB m blk
-> HasCallStack => STM m (HeaderHash blk -> Maybe (BlockInfo blk))
VolatileDB.getBlockInfo         VolatileDB m blk
cdbVolatileDB
          STM
  m
  (AnchoredFragment (Header blk)
   -> Point blk
   -> LedgerDB' blk
   -> (InvalidBlocks blk, ChainHash blk -> Set (HeaderHash blk),
       HeaderHash blk -> Maybe (BlockInfo blk),
       AnchoredFragment (Header blk), Point blk, LedgerDB' blk))
-> STM m (AnchoredFragment (Header blk))
-> STM
     m
     (Point blk
      -> LedgerDB' blk
      -> (InvalidBlocks blk, ChainHash blk -> Set (HeaderHash blk),
          HeaderHash blk -> Maybe (BlockInfo blk),
          AnchoredFragment (Header blk), Point blk, LedgerDB' blk))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ChainDbEnv m blk -> STM m (AnchoredFragment (Header blk))
forall (m :: * -> *) blk.
(IOLike m, HasHeader (Header blk),
 ConsensusProtocol (BlockProtocol blk)) =>
ChainDbEnv m blk -> STM m (AnchoredFragment (Header blk))
Query.getCurrentChain           ChainDbEnv m blk
cdb
          STM
  m
  (Point blk
   -> LedgerDB' blk
   -> (InvalidBlocks blk, ChainHash blk -> Set (HeaderHash blk),
       HeaderHash blk -> Maybe (BlockInfo blk),
       AnchoredFragment (Header blk), Point blk, LedgerDB' blk))
-> STM m (Point blk)
-> STM
     m
     (LedgerDB' blk
      -> (InvalidBlocks blk, ChainHash blk -> Set (HeaderHash blk),
          HeaderHash blk -> Maybe (BlockInfo blk),
          AnchoredFragment (Header blk), Point blk, LedgerDB' blk))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ChainDbEnv m blk -> STM m (Point blk)
forall (m :: * -> *) blk.
(IOLike m, HasHeader (Header blk)) =>
ChainDbEnv m blk -> STM m (Point blk)
Query.getTipPoint               ChainDbEnv m blk
cdb
          STM
  m
  (LedgerDB' blk
   -> (InvalidBlocks blk, ChainHash blk -> Set (HeaderHash blk),
       HeaderHash blk -> Maybe (BlockInfo blk),
       AnchoredFragment (Header blk), Point blk, LedgerDB' blk))
-> STM m (LedgerDB' blk)
-> STM
     m
     (InvalidBlocks blk, ChainHash blk -> Set (HeaderHash blk),
      HeaderHash blk -> Maybe (BlockInfo blk),
      AnchoredFragment (Header blk), Point blk, LedgerDB' blk)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LgrDB m blk -> STM m (LedgerDB' blk)
forall (m :: * -> *) blk.
IOLike m =>
LgrDB m blk -> STM m (LedgerDB' blk)
LgrDB.getCurrent                LgrDB m blk
cdbLgrDB
    let curChainAndLedger :: ChainAndLedger blk
        curChainAndLedger :: ChainAndLedger blk
curChainAndLedger =
          -- The current chain we're working with here is not longer than @k@
          -- blocks (see 'getCurrentChain' and 'cdbChain'), which is easier to
          -- reason about when doing chain selection, etc.
          Bool -> ChainAndLedger blk -> ChainAndLedger blk
forall a. HasCallStack => Bool -> a -> a
assert (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (AnchoredFragment (Header blk) -> Int
forall block. HasHeader block => AnchoredFragment block -> Int
AF.length AnchoredFragment (Header blk)
curChain) Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word64
k) (ChainAndLedger blk -> ChainAndLedger blk)
-> ChainAndLedger blk -> ChainAndLedger blk
forall a b. (a -> b) -> a -> b
$
          AnchoredFragment (Header blk)
-> LedgerDB' blk -> ChainAndLedger blk
forall l b.
(IsLedger l, HasHeader b, HeaderHash b ~ HeaderHash l,
 HasCallStack) =>
AnchoredFragment b -> l -> ValidatedFragment b l
VF.ValidatedFragment AnchoredFragment (Header blk)
curChain LedgerDB' blk
ledgerDB

        immBlockNo :: WithOrigin BlockNo
        immBlockNo :: WithOrigin BlockNo
immBlockNo = AnchoredFragment (Header blk) -> WithOrigin BlockNo
forall block. AnchoredFragment block -> WithOrigin BlockNo
AF.anchorBlockNo AnchoredFragment (Header blk)
curChain

        -- Let these two functions ignore invalid blocks
        lookupBlockInfo' :: HeaderHash blk -> Maybe (BlockInfo blk)
lookupBlockInfo' = ChainDbEnv m blk
-> InvalidBlocks blk
-> (HeaderHash blk -> Maybe (BlockInfo blk))
-> HeaderHash blk
-> Maybe (BlockInfo blk)
forall blk (proxy :: * -> *) a.
HasHeader blk =>
proxy blk
-> InvalidBlocks blk
-> (HeaderHash blk -> Maybe a)
-> HeaderHash blk
-> Maybe a
ignoreInvalid    ChainDbEnv m blk
cdb InvalidBlocks blk
invalid HeaderHash blk -> Maybe (BlockInfo blk)
lookupBlockInfo
        succsOf' :: ChainHash blk -> Set (HeaderHash blk)
succsOf'         = ChainDbEnv m blk
-> InvalidBlocks blk
-> (ChainHash blk -> Set (HeaderHash blk))
-> ChainHash blk
-> Set (HeaderHash blk)
forall blk (proxy :: * -> *).
HasHeader blk =>
proxy blk
-> InvalidBlocks blk
-> (ChainHash blk -> Set (HeaderHash blk))
-> ChainHash blk
-> Set (HeaderHash blk)
ignoreInvalidSuc ChainDbEnv m blk
cdb InvalidBlocks blk
invalid ChainHash blk -> Set (HeaderHash blk)
succsOf

    -- The preconditions
    Bool -> m () -> m ()
forall a. HasCallStack => Bool -> a -> a
assert (Maybe (BlockInfo blk) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (BlockInfo blk) -> Bool) -> Maybe (BlockInfo blk) -> Bool
forall a b. (a -> b) -> a -> b
$ HeaderHash blk -> Maybe (BlockInfo blk)
lookupBlockInfo (Header blk -> HeaderHash blk
forall blk. HasHeader (Header blk) => Header blk -> HeaderHash blk
headerHash Header blk
hdr)) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    if
      -- The chain might have grown since we added the block such that the
      -- block is older than @k@.
      | Header blk -> IsEBB -> WithOrigin BlockNo -> Bool
forall blk.
HasHeader (Header blk) =>
Header blk -> IsEBB -> WithOrigin BlockNo -> Bool
olderThanK Header blk
hdr IsEBB
isEBB WithOrigin BlockNo
immBlockNo -> do
        TraceAddBlockEvent blk -> m ()
trace (TraceAddBlockEvent blk -> m ()) -> TraceAddBlockEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$ RealPoint blk -> TraceAddBlockEvent blk
forall blk. RealPoint blk -> TraceAddBlockEvent blk
IgnoreBlockOlderThanK RealPoint blk
p
        Point blk -> m (Point blk)
forall (m :: * -> *) a. Monad m => a -> m a
return Point blk
tipPoint

      -- We might have validated the block in the meantime
      | Just (InvalidBlockInfo InvalidBlockReason blk
reason SlotNo
_) <- HeaderHash blk -> InvalidBlocks blk -> Maybe (InvalidBlockInfo blk)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Header blk -> HeaderHash blk
forall blk. HasHeader (Header blk) => Header blk -> HeaderHash blk
headerHash Header blk
hdr) InvalidBlocks blk
invalid -> do
        TraceAddBlockEvent blk -> m ()
trace (TraceAddBlockEvent blk -> m ()) -> TraceAddBlockEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$ RealPoint blk -> InvalidBlockReason blk -> TraceAddBlockEvent blk
forall blk.
RealPoint blk -> InvalidBlockReason blk -> TraceAddBlockEvent blk
IgnoreInvalidBlock RealPoint blk
p InvalidBlockReason blk
reason
        Point blk -> m (Point blk)
forall (m :: * -> *) a. Monad m => a -> m a
return Point blk
tipPoint

      -- The block @b@ fits onto the end of our current chain
      | Point blk -> ChainHash blk
forall block. Point block -> ChainHash block
pointHash Point blk
tipPoint ChainHash blk -> ChainHash blk -> Bool
forall a. Eq a => a -> a -> Bool
== Header blk -> ChainHash blk
forall blk. GetPrevHash blk => Header blk -> ChainHash blk
headerPrevHash Header blk
hdr -> do
        -- ### Add to current chain
        TraceAddBlockEvent blk -> m ()
trace (RealPoint blk -> TraceAddBlockEvent blk
forall blk. RealPoint blk -> TraceAddBlockEvent blk
TryAddToCurrentChain RealPoint blk
p)
        HasCallStack =>
(ChainHash blk -> Set (HeaderHash blk))
-> ChainAndLedger blk -> m (Point blk)
(ChainHash blk -> Set (HeaderHash blk))
-> ChainAndLedger blk -> m (Point blk)
addToCurrentChain ChainHash blk -> Set (HeaderHash blk)
succsOf' ChainAndLedger blk
curChainAndLedger

      | Just ChainDiff (HeaderFields blk)
diff <- (HeaderHash blk -> Maybe (BlockInfo blk))
-> AnchoredFragment (Header blk)
-> RealPoint blk
-> Maybe (ChainDiff (HeaderFields blk))
forall blk.
(HasHeader blk, GetHeader blk, HasCallStack) =>
LookupBlockInfo blk
-> AnchoredFragment (Header blk)
-> RealPoint blk
-> Maybe (ChainDiff (HeaderFields blk))
Paths.isReachable HeaderHash blk -> Maybe (BlockInfo blk)
lookupBlockInfo' AnchoredFragment (Header blk)
curChain RealPoint blk
p -> do
        -- ### Switch to a fork
        TraceAddBlockEvent blk -> m ()
trace (RealPoint blk
-> ChainDiff (HeaderFields blk) -> TraceAddBlockEvent blk
forall blk.
RealPoint blk
-> ChainDiff (HeaderFields blk) -> TraceAddBlockEvent blk
TrySwitchToAFork RealPoint blk
p ChainDiff (HeaderFields blk)
diff)
        HasCallStack =>
(ChainHash blk -> Set (HeaderHash blk))
-> (HeaderHash blk -> Maybe (BlockInfo blk))
-> ChainAndLedger blk
-> ChainDiff (HeaderFields blk)
-> m (Point blk)
(ChainHash blk -> Set (HeaderHash blk))
-> (HeaderHash blk -> Maybe (BlockInfo blk))
-> ChainAndLedger blk
-> ChainDiff (HeaderFields blk)
-> m (Point blk)
switchToAFork ChainHash blk -> Set (HeaderHash blk)
succsOf' HeaderHash blk -> Maybe (BlockInfo blk)
lookupBlockInfo' ChainAndLedger blk
curChainAndLedger ChainDiff (HeaderFields blk)
diff

      | Bool
otherwise -> do
        -- ### Store but don't change the current chain
        TraceAddBlockEvent blk -> m ()
trace (RealPoint blk -> TraceAddBlockEvent blk
forall blk. RealPoint blk -> TraceAddBlockEvent blk
StoreButDontChange RealPoint blk
p)
        Point blk -> m (Point blk)
forall (m :: * -> *) a. Monad m => a -> m a
return Point blk
tipPoint

    -- Note that we may have extended the chain, but have not trimmed it to
    -- @k@ blocks/headers. That is the job of the background thread, which
    -- will first copy the blocks/headers to trim (from the end of the
    -- fragment) from the VolatileDB to the ImmutableDB.
  where
    SecurityParam Word64
k = TopLevelConfig blk -> SecurityParam
forall blk.
ConsensusProtocol (BlockProtocol blk) =>
TopLevelConfig blk -> SecurityParam
configSecurityParam TopLevelConfig blk
cdbTopLevelConfig

    p :: RealPoint blk
    p :: RealPoint blk
p = Header blk -> RealPoint blk
forall blk. HasHeader (Header blk) => Header blk -> RealPoint blk
headerRealPoint Header blk
hdr

    isEBB :: IsEBB
    isEBB :: IsEBB
isEBB = Header blk -> IsEBB
forall blk. GetHeader blk => Header blk -> IsEBB
headerToIsEBB Header blk
hdr

    trace :: TraceAddBlockEvent blk -> m ()
    trace :: TraceAddBlockEvent blk -> m ()
trace = Tracer m (TraceAddBlockEvent blk) -> TraceAddBlockEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith ((TraceAddBlockEvent blk -> TraceEvent blk)
-> Tracer m (TraceEvent blk) -> Tracer m (TraceAddBlockEvent blk)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap TraceAddBlockEvent blk -> TraceEvent blk
forall blk. TraceAddBlockEvent blk -> TraceEvent blk
TraceAddBlockEvent Tracer m (TraceEvent blk)
cdbTracer)

    mkChainSelEnv :: ChainAndLedger blk -> ChainSelEnv m blk
    mkChainSelEnv :: ChainAndLedger blk -> ChainSelEnv m blk
mkChainSelEnv ChainAndLedger blk
curChainAndLedger = ChainSelEnv :: forall (m :: * -> *) blk.
LgrDB m blk
-> (TraceValidationEvent blk -> m ())
-> TopLevelConfig blk
-> StrictTVar m (WithFingerprint (InvalidBlocks blk))
-> StrictTVar m (FutureBlocks blk)
-> CheckInFuture m blk
-> BlockCache blk
-> ChainAndLedger blk
-> ChainSelEnv m blk
ChainSelEnv
      { lgrDB :: LgrDB m blk
lgrDB             = LgrDB m blk
cdbLgrDB
      , cfg :: TopLevelConfig blk
cfg               = TopLevelConfig blk
cdbTopLevelConfig
      , varInvalid :: StrictTVar m (WithFingerprint (InvalidBlocks blk))
varInvalid        = StrictTVar m (WithFingerprint (InvalidBlocks blk))
cdbInvalid
      , varFutureBlocks :: StrictTVar m (FutureBlocks blk)
varFutureBlocks   = StrictTVar m (FutureBlocks blk)
cdbFutureBlocks
      , futureCheck :: CheckInFuture m blk
futureCheck       = CheckInFuture m blk
cdbCheckInFuture
      , blockCache :: BlockCache blk
blockCache        = BlockCache blk
blockCache
      , curChainAndLedger :: ChainAndLedger blk
curChainAndLedger = ChainAndLedger blk
curChainAndLedger
      , trace :: TraceValidationEvent blk -> m ()
trace             =
          Tracer m (TraceValidationEvent blk)
-> TraceValidationEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith ((TraceValidationEvent blk -> TraceEvent blk)
-> Tracer m (TraceEvent blk) -> Tracer m (TraceValidationEvent blk)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (TraceAddBlockEvent blk -> TraceEvent blk
forall blk. TraceAddBlockEvent blk -> TraceEvent blk
TraceAddBlockEvent (TraceAddBlockEvent blk -> TraceEvent blk)
-> (TraceValidationEvent blk -> TraceAddBlockEvent blk)
-> TraceValidationEvent blk
-> TraceEvent blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TraceValidationEvent blk -> TraceAddBlockEvent blk
forall blk. TraceValidationEvent blk -> TraceAddBlockEvent blk
AddBlockValidation) Tracer m (TraceEvent blk)
cdbTracer)
      }

    -- | PRECONDITION: the header @hdr@ (and block @b@) fit onto the end of
    -- the current chain.
    addToCurrentChain ::
         HasCallStack
      => (ChainHash blk -> Set (HeaderHash blk))
      -> ChainAndLedger blk
         -- ^ The current chain and ledger
      -> m (Point blk)
    addToCurrentChain :: (ChainHash blk -> Set (HeaderHash blk))
-> ChainAndLedger blk -> m (Point blk)
addToCurrentChain ChainHash blk -> Set (HeaderHash blk)
succsOf ChainAndLedger blk
curChainAndLedger = do
        let suffixesAfterB :: [NonEmpty (HeaderHash blk)]
suffixesAfterB = (ChainHash blk -> Set (HeaderHash blk))
-> Point blk -> [NonEmpty (HeaderHash blk)]
forall blk.
(ChainHash blk -> Set (HeaderHash blk))
-> Point blk -> [NonEmpty (HeaderHash blk)]
Paths.candidates ChainHash blk -> Set (HeaderHash blk)
succsOf (RealPoint blk -> Point blk
forall blk. RealPoint blk -> Point blk
realPointToPoint RealPoint blk
p)

        -- Fragments that are anchored at @curHead@, i.e. suffixes of the
        -- current chain.
        NonEmpty (AnchoredFragment (Header blk))
candidates <- case [NonEmpty (HeaderHash blk)]
-> Maybe (NonEmpty (NonEmpty (HeaderHash blk)))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [NonEmpty (HeaderHash blk)]
suffixesAfterB of
          -- If there are no suffixes after @b@, just use the suffix just
          -- containing @b@ as the sole candidate.
          Maybe (NonEmpty (NonEmpty (HeaderHash blk)))
Nothing              ->
            NonEmpty (AnchoredFragment (Header blk))
-> m (NonEmpty (AnchoredFragment (Header blk)))
forall (m :: * -> *) a. Monad m => a -> m a
return (NonEmpty (AnchoredFragment (Header blk))
 -> m (NonEmpty (AnchoredFragment (Header blk))))
-> NonEmpty (AnchoredFragment (Header blk))
-> m (NonEmpty (AnchoredFragment (Header blk)))
forall a b. (a -> b) -> a -> b
$ (Anchor (Header blk)
-> [Header blk] -> AnchoredFragment (Header blk)
forall block.
HasHeader block =>
Anchor block -> [block] -> AnchoredFragment block
AF.fromOldestFirst Anchor (Header blk)
curHead [Header blk
hdr]) AnchoredFragment (Header blk)
-> [AnchoredFragment (Header blk)]
-> NonEmpty (AnchoredFragment (Header blk))
forall a. a -> [a] -> NonEmpty a
NE.:| []
          Just NonEmpty (NonEmpty (HeaderHash blk))
suffixesAfterB' ->
            -- We can start with an empty cache, because we're only looking
            -- up the headers /after/ b, so they won't be on the current
            -- chain.
            (StateT
   (FutureBlocks blk) m (NonEmpty (AnchoredFragment (Header blk)))
 -> FutureBlocks blk
 -> m (NonEmpty (AnchoredFragment (Header blk))))
-> FutureBlocks blk
-> StateT
     (FutureBlocks blk) m (NonEmpty (AnchoredFragment (Header blk)))
-> m (NonEmpty (AnchoredFragment (Header blk)))
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT
  (FutureBlocks blk) m (NonEmpty (AnchoredFragment (Header blk)))
-> FutureBlocks blk -> m (NonEmpty (AnchoredFragment (Header blk)))
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT FutureBlocks blk
forall k a. Map k a
Map.empty (StateT
   (FutureBlocks blk) m (NonEmpty (AnchoredFragment (Header blk)))
 -> m (NonEmpty (AnchoredFragment (Header blk))))
-> StateT
     (FutureBlocks blk) m (NonEmpty (AnchoredFragment (Header blk)))
-> m (NonEmpty (AnchoredFragment (Header blk)))
forall a b. (a -> b) -> a -> b
$ NonEmpty (NonEmpty (HeaderHash blk))
-> (NonEmpty (HeaderHash blk)
    -> StateT (FutureBlocks blk) m (AnchoredFragment (Header blk)))
-> StateT
     (FutureBlocks blk) m (NonEmpty (AnchoredFragment (Header blk)))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM NonEmpty (NonEmpty (HeaderHash blk))
suffixesAfterB' ((NonEmpty (HeaderHash blk)
  -> StateT (FutureBlocks blk) m (AnchoredFragment (Header blk)))
 -> StateT
      (FutureBlocks blk) m (NonEmpty (AnchoredFragment (Header blk))))
-> (NonEmpty (HeaderHash blk)
    -> StateT (FutureBlocks blk) m (AnchoredFragment (Header blk)))
-> StateT
     (FutureBlocks blk) m (NonEmpty (AnchoredFragment (Header blk)))
forall a b. (a -> b) -> a -> b
$ \NonEmpty (HeaderHash blk)
hashes -> do
              [Header blk]
hdrs <- (HeaderHash blk -> StateT (FutureBlocks blk) m (Header blk))
-> [HeaderHash blk] -> StateT (FutureBlocks blk) m [Header blk]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (VolatileDB m blk
-> HeaderHash blk -> StateT (FutureBlocks blk) m (Header blk)
forall (m :: * -> *) blk.
(MonadThrow m, HasHeader blk) =>
VolatileDB m blk
-> HeaderHash blk
-> StateT (Map (HeaderHash blk) (Header blk)) m (Header blk)
getKnownHeaderThroughCache VolatileDB m blk
cdbVolatileDB) ([HeaderHash blk] -> StateT (FutureBlocks blk) m [Header blk])
-> [HeaderHash blk] -> StateT (FutureBlocks blk) m [Header blk]
forall a b. (a -> b) -> a -> b
$
                        NonEmpty (HeaderHash blk) -> [HeaderHash blk]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty (HeaderHash blk)
hashes
              AnchoredFragment (Header blk)
-> StateT (FutureBlocks blk) m (AnchoredFragment (Header blk))
forall (m :: * -> *) a. Monad m => a -> m a
return (AnchoredFragment (Header blk)
 -> StateT (FutureBlocks blk) m (AnchoredFragment (Header blk)))
-> AnchoredFragment (Header blk)
-> StateT (FutureBlocks blk) m (AnchoredFragment (Header blk))
forall a b. (a -> b) -> a -> b
$ Anchor (Header blk)
-> [Header blk] -> AnchoredFragment (Header blk)
forall block.
HasHeader block =>
Anchor block -> [block] -> AnchoredFragment block
AF.fromOldestFirst Anchor (Header blk)
curHead (Header blk
hdr Header blk -> [Header blk] -> [Header blk]
forall a. a -> [a] -> [a]
: [Header blk]
hdrs)

        let chainDiffs :: Maybe (NonEmpty (ChainDiff (Header blk)))
chainDiffs = [ChainDiff (Header blk)]
-> Maybe (NonEmpty (ChainDiff (Header blk)))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty
              ([ChainDiff (Header blk)]
 -> Maybe (NonEmpty (ChainDiff (Header blk))))
-> [ChainDiff (Header blk)]
-> Maybe (NonEmpty (ChainDiff (Header blk)))
forall a b. (a -> b) -> a -> b
$ (ChainDiff (Header blk) -> Bool)
-> NonEmpty (ChainDiff (Header blk)) -> [ChainDiff (Header blk)]
forall a. (a -> Bool) -> NonEmpty a -> [a]
NE.filter ( TopLevelConfig blk
-> AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk)
-> Bool
forall blk.
BlockSupportsProtocol blk =>
TopLevelConfig blk
-> AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk)
-> Bool
preferAnchoredCandidate TopLevelConfig blk
cdbTopLevelConfig AnchoredFragment (Header blk)
curChain
                          (AnchoredFragment (Header blk) -> Bool)
-> (ChainDiff (Header blk) -> AnchoredFragment (Header blk))
-> ChainDiff (Header blk)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainDiff (Header blk) -> AnchoredFragment (Header blk)
forall b. ChainDiff b -> AnchoredFragment b
Diff.getSuffix
                          )
              (NonEmpty (ChainDiff (Header blk)) -> [ChainDiff (Header blk)])
-> NonEmpty (ChainDiff (Header blk)) -> [ChainDiff (Header blk)]
forall a b. (a -> b) -> a -> b
$ (AnchoredFragment (Header blk) -> ChainDiff (Header blk))
-> NonEmpty (AnchoredFragment (Header blk))
-> NonEmpty (ChainDiff (Header blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AnchoredFragment (Header blk) -> ChainDiff (Header blk)
forall b. AnchoredFragment b -> ChainDiff b
Diff.extend NonEmpty (AnchoredFragment (Header blk))
candidates
        -- All candidates are longer than the current chain, so they will be
        -- preferred over it, /unless/ the block we just added is an EBB,
        -- which has the same 'BlockNo' as the block before it, so when
        -- using the 'BlockNo' as the proxy for the length (note that some
        -- protocols might do it differently), the candidate with the EBB
        -- appended will not be preferred over the current chain.
        --
        -- The consequence of this is that when adding an EBB, it will not
        -- be selected by chain selection and thus not appended to the chain
        -- until the block after it is added, which will again result in a
        -- candidate preferred over the current chain. In this case, the
        -- candidate will be a two-block (the EBB and the new block)
        -- extension of the current chain.
        case Maybe (NonEmpty (ChainDiff (Header blk)))
chainDiffs of
          Maybe (NonEmpty (ChainDiff (Header blk)))
Nothing          -> Point blk -> m (Point blk)
forall (m :: * -> *) a. Monad m => a -> m a
return Point blk
curTip
          Just NonEmpty (ChainDiff (Header blk))
chainDiffs' ->
            ChainSelEnv m blk
-> NonEmpty (ChainDiff (Header blk))
-> m (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsProtocol blk, HasCallStack) =>
ChainSelEnv m blk
-> NonEmpty (ChainDiff (Header blk))
-> m (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
chainSelection ChainSelEnv m blk
chainSelEnv NonEmpty (ChainDiff (Header blk))
chainDiffs' m (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
-> (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk))
    -> m (Point blk))
-> m (Point blk)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk))
Nothing ->
                Point blk -> m (Point blk)
forall (m :: * -> *) a. Monad m => a -> m a
return Point blk
curTip
              Just ValidatedChainDiff (Header blk) (LedgerDB' blk)
validatedChainDiff ->
                HasCallStack =>
ValidatedChainDiff (Header blk) (LedgerDB' blk)
-> ([LedgerEvent blk]
    -> NewTipInfo blk
    -> AnchoredFragment (Header blk)
    -> AnchoredFragment (Header blk)
    -> TraceAddBlockEvent blk)
-> m (Point blk)
ValidatedChainDiff (Header blk) (LedgerDB' blk)
-> ([LedgerEvent blk]
    -> NewTipInfo blk
    -> AnchoredFragment (Header blk)
    -> AnchoredFragment (Header blk)
    -> TraceAddBlockEvent blk)
-> m (Point blk)
switchTo ValidatedChainDiff (Header blk) (LedgerDB' blk)
validatedChainDiff [LedgerEvent blk]
-> NewTipInfo blk
-> AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk)
-> TraceAddBlockEvent blk
forall blk.
[LedgerEvent blk]
-> NewTipInfo blk
-> AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk)
-> TraceAddBlockEvent blk
AddedToCurrentChain
      where
        chainSelEnv :: ChainSelEnv m blk
chainSelEnv = ChainAndLedger blk -> ChainSelEnv m blk
mkChainSelEnv ChainAndLedger blk
curChainAndLedger
        curChain :: AnchoredFragment (Header blk)
curChain    = ChainAndLedger blk -> AnchoredFragment (Header blk)
forall b l. ValidatedFragment b l -> AnchoredFragment b
VF.validatedFragment ChainAndLedger blk
curChainAndLedger
        curTip :: Point blk
curTip      = Point (Header blk) -> Point blk
forall b b'.
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point (Header blk) -> Point blk)
-> Point (Header blk) -> Point blk
forall a b. (a -> b) -> a -> b
$ AnchoredFragment (Header blk) -> Point (Header blk)
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.headPoint AnchoredFragment (Header blk)
curChain
        curHead :: Anchor (Header blk)
curHead     = AnchoredFragment (Header blk) -> Anchor (Header blk)
forall block.
HasHeader block =>
AnchoredFragment block -> Anchor block
AF.headAnchor AnchoredFragment (Header blk)
curChain

    -- | We have found a 'ChainDiff' through the VolatileDB connecting the new
    -- block to the current chain. We'll call the intersection/anchor @x@.
    --
    -- We try to extend this path by looking for forks that start with the
    -- given block, then we do chain selection and /possibly/ try to switch to
    -- a new fork.
    switchToAFork ::
         HasCallStack
      => (ChainHash blk -> Set (HeaderHash blk))
      -> LookupBlockInfo blk
      -> ChainAndLedger blk
         -- ^ The current chain (anchored at @i@) and ledger
      -> ChainDiff (HeaderFields blk)
         -- ^ Header fields for @(x,b]@
      -> m (Point blk)
    switchToAFork :: (ChainHash blk -> Set (HeaderHash blk))
-> (HeaderHash blk -> Maybe (BlockInfo blk))
-> ChainAndLedger blk
-> ChainDiff (HeaderFields blk)
-> m (Point blk)
switchToAFork ChainHash blk -> Set (HeaderHash blk)
succsOf HeaderHash blk -> Maybe (BlockInfo blk)
lookupBlockInfo ChainAndLedger blk
curChainAndLedger ChainDiff (HeaderFields blk)
diff = do
        -- We use a cache to avoid reading the headers from disk multiple
        -- times in case they're part of multiple forks that go through @b@.
        let initCache :: FutureBlocks blk
initCache = HeaderHash blk -> Header blk -> FutureBlocks blk
forall k a. k -> a -> Map k a
Map.singleton (Header blk -> HeaderHash blk
forall blk. HasHeader (Header blk) => Header blk -> HeaderHash blk
headerHash Header blk
hdr) Header blk
hdr
        [ChainDiff (Header blk)]
chainDiffs <-
          -- 4. Filter out candidates that are not preferred over the current
          -- chain.
          --
          -- The suffixes all fork off from the current chain within @k@
          -- blocks, so it satisfies the precondition of 'preferCandidate'.
            ([ChainDiff (Header blk)] -> [ChainDiff (Header blk)])
-> m [ChainDiff (Header blk)] -> m [ChainDiff (Header blk)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
              ( (ChainDiff (Header blk) -> Bool)
-> [ChainDiff (Header blk)] -> [ChainDiff (Header blk)]
forall a. (a -> Bool) -> [a] -> [a]
filter
                  ( TopLevelConfig blk
-> AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk)
-> Bool
forall blk.
BlockSupportsProtocol blk =>
TopLevelConfig blk
-> AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk)
-> Bool
preferAnchoredCandidate TopLevelConfig blk
cdbTopLevelConfig AnchoredFragment (Header blk)
curChain
                  (AnchoredFragment (Header blk) -> Bool)
-> (ChainDiff (Header blk) -> AnchoredFragment (Header blk))
-> ChainDiff (Header blk)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainDiff (Header blk) -> AnchoredFragment (Header blk)
forall b. ChainDiff b -> AnchoredFragment b
Diff.getSuffix
                  )
              )
            -- 3. Translate the 'HeaderFields' to 'Header' by reading the
            -- headers from disk.
          (m [ChainDiff (Header blk)] -> m [ChainDiff (Header blk)])
-> (ChainDiff (HeaderFields blk) -> m [ChainDiff (Header blk)])
-> ChainDiff (HeaderFields blk)
-> m [ChainDiff (Header blk)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StateT (FutureBlocks blk) m [ChainDiff (Header blk)]
 -> FutureBlocks blk -> m [ChainDiff (Header blk)])
-> FutureBlocks blk
-> StateT (FutureBlocks blk) m [ChainDiff (Header blk)]
-> m [ChainDiff (Header blk)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT (FutureBlocks blk) m [ChainDiff (Header blk)]
-> FutureBlocks blk -> m [ChainDiff (Header blk)]
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT FutureBlocks blk
initCache
          (StateT (FutureBlocks blk) m [ChainDiff (Header blk)]
 -> m [ChainDiff (Header blk)])
-> (ChainDiff (HeaderFields blk)
    -> StateT (FutureBlocks blk) m [ChainDiff (Header blk)])
-> ChainDiff (HeaderFields blk)
-> m [ChainDiff (Header blk)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ChainDiff (HeaderFields blk)
 -> StateT (FutureBlocks blk) m (ChainDiff (Header blk)))
-> [ChainDiff (HeaderFields blk)]
-> StateT (FutureBlocks blk) m [ChainDiff (Header blk)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ChainDiff (HeaderFields blk)
-> StateT (FutureBlocks blk) m (ChainDiff (Header blk))
translateToHeaders
            -- 2. Filter out candidates that are shorter than the current
            -- chain. We don't want to needlessly read the headers from disk
            -- for those candidates.
          ([ChainDiff (HeaderFields blk)]
 -> StateT (FutureBlocks blk) m [ChainDiff (Header blk)])
-> (ChainDiff (HeaderFields blk) -> [ChainDiff (HeaderFields blk)])
-> ChainDiff (HeaderFields blk)
-> StateT (FutureBlocks blk) m [ChainDiff (Header blk)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ChainDiff (HeaderFields blk) -> Bool)
-> NonEmpty (ChainDiff (HeaderFields blk))
-> [ChainDiff (HeaderFields blk)]
forall a. (a -> Bool) -> NonEmpty a -> [a]
NE.filter (Bool -> Bool
not (Bool -> Bool)
-> (ChainDiff (HeaderFields blk) -> Bool)
-> ChainDiff (HeaderFields blk)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainDiff (HeaderFields blk) -> Bool
forall b. HasHeader b => ChainDiff b -> Bool
Diff.rollbackExceedsSuffix)
            -- 1. Extend the diff with candidates fitting on @B@
          (NonEmpty (ChainDiff (HeaderFields blk))
 -> [ChainDiff (HeaderFields blk)])
-> (ChainDiff (HeaderFields blk)
    -> NonEmpty (ChainDiff (HeaderFields blk)))
-> ChainDiff (HeaderFields blk)
-> [ChainDiff (HeaderFields blk)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ChainHash blk -> Set (HeaderHash blk))
-> (HeaderHash blk -> Maybe (BlockInfo blk))
-> ChainDiff (HeaderFields blk)
-> NonEmpty (ChainDiff (HeaderFields blk))
forall blk.
HasHeader blk =>
(ChainHash blk -> Set (HeaderHash blk))
-> LookupBlockInfo blk
-> ChainDiff (HeaderFields blk)
-> NonEmpty (ChainDiff (HeaderFields blk))
Paths.extendWithSuccessors ChainHash blk -> Set (HeaderHash blk)
succsOf HeaderHash blk -> Maybe (BlockInfo blk)
lookupBlockInfo
          (ChainDiff (HeaderFields blk) -> m [ChainDiff (Header blk)])
-> ChainDiff (HeaderFields blk) -> m [ChainDiff (Header blk)]
forall a b. (a -> b) -> a -> b
$ ChainDiff (HeaderFields blk)
diff

        case [ChainDiff (Header blk)]
-> Maybe (NonEmpty (ChainDiff (Header blk)))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [ChainDiff (Header blk)]
chainDiffs of
          -- No candidates preferred over the current chain
          Maybe (NonEmpty (ChainDiff (Header blk)))
Nothing          -> Point blk -> m (Point blk)
forall (m :: * -> *) a. Monad m => a -> m a
return Point blk
curTip
          Just NonEmpty (ChainDiff (Header blk))
chainDiffs' ->
            ChainSelEnv m blk
-> NonEmpty (ChainDiff (Header blk))
-> m (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsProtocol blk, HasCallStack) =>
ChainSelEnv m blk
-> NonEmpty (ChainDiff (Header blk))
-> m (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
chainSelection ChainSelEnv m blk
chainSelEnv NonEmpty (ChainDiff (Header blk))
chainDiffs' m (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
-> (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk))
    -> m (Point blk))
-> m (Point blk)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk))
Nothing                 ->
                Point blk -> m (Point blk)
forall (m :: * -> *) a. Monad m => a -> m a
return Point blk
curTip
              Just ValidatedChainDiff (Header blk) (LedgerDB' blk)
validatedChainDiff ->
                HasCallStack =>
ValidatedChainDiff (Header blk) (LedgerDB' blk)
-> ([LedgerEvent blk]
    -> NewTipInfo blk
    -> AnchoredFragment (Header blk)
    -> AnchoredFragment (Header blk)
    -> TraceAddBlockEvent blk)
-> m (Point blk)
ValidatedChainDiff (Header blk) (LedgerDB' blk)
-> ([LedgerEvent blk]
    -> NewTipInfo blk
    -> AnchoredFragment (Header blk)
    -> AnchoredFragment (Header blk)
    -> TraceAddBlockEvent blk)
-> m (Point blk)
switchTo ValidatedChainDiff (Header blk) (LedgerDB' blk)
validatedChainDiff [LedgerEvent blk]
-> NewTipInfo blk
-> AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk)
-> TraceAddBlockEvent blk
forall blk.
[LedgerEvent blk]
-> NewTipInfo blk
-> AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk)
-> TraceAddBlockEvent blk
SwitchedToAFork
      where
        chainSelEnv :: ChainSelEnv m blk
chainSelEnv = ChainAndLedger blk -> ChainSelEnv m blk
mkChainSelEnv ChainAndLedger blk
curChainAndLedger
        curChain :: AnchoredFragment (Header blk)
curChain    = ChainAndLedger blk -> AnchoredFragment (Header blk)
forall b l. ValidatedFragment b l -> AnchoredFragment b
VF.validatedFragment ChainAndLedger blk
curChainAndLedger
        curTip :: Point blk
curTip      = Point (Header blk) -> Point blk
forall b b'.
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point (Header blk) -> Point blk)
-> Point (Header blk) -> Point blk
forall a b. (a -> b) -> a -> b
$ AnchoredFragment (Header blk) -> Point (Header blk)
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.headPoint AnchoredFragment (Header blk)
curChain

    -- | Create a 'NewTipInfo' corresponding to the tip of the given ledger.
    mkNewTipInfo :: LedgerDB' blk -> NewTipInfo blk
    mkNewTipInfo :: LedgerDB' blk -> NewTipInfo blk
mkNewTipInfo LedgerDB' blk
newLedgerDB =
        NewTipInfo :: forall blk.
RealPoint blk
-> EpochNo -> Word64 -> RealPoint blk -> NewTipInfo blk
NewTipInfo {
            newTipPoint :: RealPoint blk
newTipPoint       = RealPoint blk
tipPoint
          , newTipEpoch :: EpochNo
newTipEpoch       = EpochNo
tipEpoch
          , newTipSlotInEpoch :: Word64
newTipSlotInEpoch = Word64
tipSlotInEpoch
          , newTipTrigger :: RealPoint blk
newTipTrigger     = RealPoint blk
p
          }
      where
        cfg :: TopLevelConfig blk
        cfg :: TopLevelConfig blk
cfg = TopLevelConfig blk
cdbTopLevelConfig

        ledger :: LedgerState blk
        ledger :: LedgerState blk
ledger = ExtLedgerState blk -> LedgerState blk
forall blk. ExtLedgerState blk -> LedgerState blk
ledgerState (LedgerDB' blk -> ExtLedgerState blk
forall l r. LedgerDB l r -> l
LgrDB.ledgerDbCurrent LedgerDB' blk
newLedgerDB)

        summary :: History.Summary (HardForkIndices blk)
        summary :: Summary (HardForkIndices blk)
summary = LedgerConfig blk
-> LedgerState blk -> Summary (HardForkIndices blk)
forall blk.
HasHardForkHistory blk =>
LedgerConfig blk
-> LedgerState blk -> Summary (HardForkIndices blk)
hardForkSummary
                    (TopLevelConfig blk -> LedgerConfig blk
forall blk. TopLevelConfig blk -> LedgerConfig blk
configLedger TopLevelConfig blk
cfg)
                    LedgerState blk
ledger

        (RealPoint blk
tipPoint, (EpochNo
tipEpoch, Word64
tipSlotInEpoch)) =
          case Point blk -> WithOrigin (RealPoint blk)
forall blk. Point blk -> WithOrigin (RealPoint blk)
pointToWithOriginRealPoint
                 (Proxy blk -> LedgerState blk -> Point blk
forall blk.
UpdateLedger blk =>
Proxy blk -> LedgerState blk -> Point blk
ledgerTipPoint (Proxy blk
forall k (t :: k). Proxy t
Proxy @blk) LedgerState blk
ledger) of
            WithOrigin (RealPoint blk)
Origin        -> [Char] -> (RealPoint blk, (EpochNo, Word64))
forall a. HasCallStack => [Char] -> a
error [Char]
"cannot have switched to an empty chain"
            NotOrigin RealPoint blk
tip ->
              let query :: Qry (EpochNo, Word64)
query = SlotNo -> Qry (EpochNo, Word64)
History.slotToEpoch' (RealPoint blk -> SlotNo
forall blk. RealPoint blk -> SlotNo
realPointSlot RealPoint blk
tip)
              in (RealPoint blk
tip, Qry (EpochNo, Word64)
-> Summary (HardForkIndices blk) -> (EpochNo, Word64)
forall a (xs :: [*]). HasCallStack => Qry a -> Summary xs -> a
History.runQueryPure Qry (EpochNo, Word64)
query Summary (HardForkIndices blk)
summary)

    -- | Try to apply the given 'ChainDiff' on the current chain fragment. The
    -- 'LgrDB.LedgerDB' is updated in the same transaction.
    --
    -- Note that we /cannot/ have switched to a different current chain in the
    -- meantime, since this function will only be called by a single
    -- background thread.
    --
    -- It /is/ possible that the background thread copying headers older than
    -- @k@ from the VolatileDB to the ImmutableDB has removed some headers
    -- from the beginning of the current chain fragment, but does not affect
    -- us, as we cannot roll back more than @k@ headers anyway.
    switchTo
      :: HasCallStack
      => ValidatedChainDiff (Header blk) (LedgerDB' blk)
         -- ^ Chain and ledger to switch to
      -> (    [LedgerEvent blk]
           -> NewTipInfo blk
           -> AnchoredFragment (Header blk)
           -> AnchoredFragment (Header blk)
           -> TraceAddBlockEvent blk
         )
         -- ^ Given the 'NewTipInfo', the previous chain, and the new chain,
         -- return the event to trace when we switched to the new chain.
      -> m (Point blk)
    switchTo :: ValidatedChainDiff (Header blk) (LedgerDB' blk)
-> ([LedgerEvent blk]
    -> NewTipInfo blk
    -> AnchoredFragment (Header blk)
    -> AnchoredFragment (Header blk)
    -> TraceAddBlockEvent blk)
-> m (Point blk)
switchTo (ValidatedChainDiff ChainDiff (Header blk)
chainDiff LedgerDB' blk
newLedger) [LedgerEvent blk]
-> NewTipInfo blk
-> AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk)
-> TraceAddBlockEvent blk
mkTraceEvent = do
        (AnchoredFragment (Header blk)
curChain, AnchoredFragment (Header blk)
newChain, [LedgerEvent blk]
events) <- STM
  m
  (AnchoredFragment (Header blk), AnchoredFragment (Header blk),
   [LedgerEvent blk])
-> m (AnchoredFragment (Header blk), AnchoredFragment (Header blk),
      [LedgerEvent blk])
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM
   m
   (AnchoredFragment (Header blk), AnchoredFragment (Header blk),
    [LedgerEvent blk])
 -> m (AnchoredFragment (Header blk), AnchoredFragment (Header blk),
       [LedgerEvent blk]))
-> STM
     m
     (AnchoredFragment (Header blk), AnchoredFragment (Header blk),
      [LedgerEvent blk])
-> m (AnchoredFragment (Header blk), AnchoredFragment (Header blk),
      [LedgerEvent blk])
forall a b. (a -> b) -> a -> b
$ do
          AnchoredFragment (Header blk)
curChain  <- StrictTVar m (AnchoredFragment (Header blk))
-> STM m (AnchoredFragment (Header blk))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar         StrictTVar m (AnchoredFragment (Header blk))
cdbChain -- Not Query.getCurrentChain!
          LedgerDB' blk
curLedger <- LgrDB m blk -> STM m (LedgerDB' blk)
forall (m :: * -> *) blk.
IOLike m =>
LgrDB m blk -> STM m (LedgerDB' blk)
LgrDB.getCurrent LgrDB m blk
cdbLgrDB
          case AnchoredFragment (Header blk)
-> ChainDiff (Header blk) -> Maybe (AnchoredFragment (Header blk))
forall b.
HasHeader b =>
AnchoredFragment b -> ChainDiff b -> Maybe (AnchoredFragment b)
Diff.apply AnchoredFragment (Header blk)
curChain ChainDiff (Header blk)
chainDiff of
            -- Impossible, as described in the docstring
            Maybe (AnchoredFragment (Header blk))
Nothing       ->
              [Char]
-> STM
     m
     (AnchoredFragment (Header blk), AnchoredFragment (Header blk),
      [LedgerEvent blk])
forall a. HasCallStack => [Char] -> a
error [Char]
"chainDiff doesn't fit onto current chain"
            Just AnchoredFragment (Header blk)
newChain -> do
              StrictTVar m (AnchoredFragment (Header blk))
-> AnchoredFragment (Header blk) -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (AnchoredFragment (Header blk))
cdbChain AnchoredFragment (Header blk)
newChain
              LgrDB m blk -> LedgerDB' blk -> STM m ()
forall (m :: * -> *) blk.
IOLike m =>
LgrDB m blk -> LedgerDB' blk -> STM m ()
LgrDB.setCurrent LgrDB m blk
cdbLgrDB LedgerDB' blk
newLedger

              -- Inspect the new ledger for potential problems
              let events :: [LedgerEvent blk]
                  events :: [LedgerEvent blk]
events = TopLevelConfig blk
-> LedgerState blk -> LedgerState blk -> [LedgerEvent blk]
forall blk.
InspectLedger blk =>
TopLevelConfig blk
-> LedgerState blk -> LedgerState blk -> [LedgerEvent blk]
inspectLedger
                             TopLevelConfig blk
cdbTopLevelConfig
                             (ExtLedgerState blk -> LedgerState blk
forall blk. ExtLedgerState blk -> LedgerState blk
ledgerState (ExtLedgerState blk -> LedgerState blk)
-> ExtLedgerState blk -> LedgerState blk
forall a b. (a -> b) -> a -> b
$ LedgerDB' blk -> ExtLedgerState blk
forall l r. LedgerDB l r -> l
LgrDB.ledgerDbCurrent LedgerDB' blk
curLedger)
                             (ExtLedgerState blk -> LedgerState blk
forall blk. ExtLedgerState blk -> LedgerState blk
ledgerState (ExtLedgerState blk -> LedgerState blk)
-> ExtLedgerState blk -> LedgerState blk
forall a b. (a -> b) -> a -> b
$ LedgerDB' blk -> ExtLedgerState blk
forall l r. LedgerDB l r -> l
LgrDB.ledgerDbCurrent LedgerDB' blk
newLedger)

              -- Update the readers
              --
              -- 'Reader.switchFork' needs to know the intersection point
              -- (@ipoint@) between the old and the current chain.
              let ipoint :: Point blk
ipoint = Point (Header blk) -> Point blk
forall b b'.
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point (Header blk) -> Point blk)
-> Point (Header blk) -> Point blk
forall a b. (a -> b) -> a -> b
$ ChainDiff (Header blk) -> Point (Header blk)
forall b. ChainDiff b -> Point b
Diff.getAnchorPoint ChainDiff (Header blk)
chainDiff
              [ReaderHandle m blk]
readerHandles <- Map ReaderKey (ReaderHandle m blk) -> [ReaderHandle m blk]
forall k a. Map k a -> [a]
Map.elems (Map ReaderKey (ReaderHandle m blk) -> [ReaderHandle m blk])
-> STM m (Map ReaderKey (ReaderHandle m blk))
-> STM m [ReaderHandle m blk]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m (Map ReaderKey (ReaderHandle m blk))
-> STM m (Map ReaderKey (ReaderHandle m blk))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (Map ReaderKey (ReaderHandle m blk))
cdbReaders
              [ReaderHandle m blk]
-> (ReaderHandle m blk -> STM m ()) -> STM m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [ReaderHandle m blk]
readerHandles ((ReaderHandle m blk -> STM m ()) -> STM m ())
-> (ReaderHandle m blk -> STM m ()) -> STM m ()
forall a b. (a -> b) -> a -> b
$ \ReaderHandle m blk
readerHandle ->
                ReaderHandle m blk
-> Point blk -> AnchoredFragment (Header blk) -> STM m ()
forall (m :: * -> *) blk.
ReaderHandle m blk
-> Point blk -> AnchoredFragment (Header blk) -> STM m ()
rhSwitchFork ReaderHandle m blk
readerHandle Point blk
ipoint AnchoredFragment (Header blk)
newChain

              (AnchoredFragment (Header blk), AnchoredFragment (Header blk),
 [LedgerEvent blk])
-> STM
     m
     (AnchoredFragment (Header blk), AnchoredFragment (Header blk),
      [LedgerEvent blk])
forall (m :: * -> *) a. Monad m => a -> m a
return (AnchoredFragment (Header blk)
curChain, AnchoredFragment (Header blk)
newChain, [LedgerEvent blk]
events)

        TraceAddBlockEvent blk -> m ()
trace (TraceAddBlockEvent blk -> m ()) -> TraceAddBlockEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$ [LedgerEvent blk]
-> NewTipInfo blk
-> AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk)
-> TraceAddBlockEvent blk
mkTraceEvent [LedgerEvent blk]
events (LedgerDB' blk -> NewTipInfo blk
mkNewTipInfo LedgerDB' blk
newLedger) AnchoredFragment (Header blk)
curChain AnchoredFragment (Header blk)
newChain
        Tracer m (LedgerDB' blk) -> LedgerDB' blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (LedgerDB' blk)
cdbTraceLedger LedgerDB' blk
newLedger

        Point blk -> m (Point blk)
forall (m :: * -> *) a. Monad m => a -> m a
return (Point blk -> m (Point blk)) -> Point blk -> m (Point blk)
forall a b. (a -> b) -> a -> b
$ Point (Header blk) -> Point blk
forall b b'.
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point (Header blk) -> Point blk)
-> Point (Header blk) -> Point blk
forall a b. (a -> b) -> a -> b
$ AnchoredFragment (Header blk) -> Point (Header blk)
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.headPoint AnchoredFragment (Header blk)
newChain

    -- | We have a new block @b@ that doesn't fit onto the current chain, but
    -- we have found a 'ChainDiff' connecting it to the current chain via
    -- intersection point @x@. We may also have extended that 'ChainDiff' with
    -- more blocks fitting onto @b@, i.e., a suffix @s@.
    --
    -- We now translate that 'ChainDiff' from 'HeaderFields' to 'Header's by
    -- reading the headers from disk.
    --
    -- Note that we need to read the headers corresponding to the hashes
    -- @(x,b)@ and @(b,?]@ from disk. Not for @b@, as that's in our cache.
    translateToHeaders
      :: ChainDiff (HeaderFields blk)
      -> StateT (Map (HeaderHash blk) (Header blk))
                m
                (ChainDiff (Header blk))
         -- ^ Fork, anchored at @x@, contains (the header of) @b@ and ends
         -- with the suffix @s@.
    translateToHeaders :: ChainDiff (HeaderFields blk)
-> StateT (FutureBlocks blk) m (ChainDiff (Header blk))
translateToHeaders =
        (HeaderFields blk -> StateT (FutureBlocks blk) m (Header blk))
-> ChainDiff (HeaderFields blk)
-> StateT (FutureBlocks blk) m (ChainDiff (Header blk))
forall a b (m :: * -> *).
(HasHeader b, HeaderHash a ~ HeaderHash b, Monad m) =>
(a -> m b) -> ChainDiff a -> m (ChainDiff b)
Diff.mapM (VolatileDB m blk
-> HeaderHash blk -> StateT (FutureBlocks blk) m (Header blk)
forall (m :: * -> *) blk.
(MonadThrow m, HasHeader blk) =>
VolatileDB m blk
-> HeaderHash blk
-> StateT (Map (HeaderHash blk) (Header blk)) m (Header blk)
getKnownHeaderThroughCache VolatileDB m blk
cdbVolatileDB (HeaderHash blk -> StateT (FutureBlocks blk) m (Header blk))
-> (HeaderFields blk -> HeaderHash blk)
-> HeaderFields blk
-> StateT (FutureBlocks blk) m (Header blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderFields blk -> HeaderHash blk
forall b. HeaderFields b -> HeaderHash b
headerFieldHash)

-- | Check whether the header for the hash is in the cache, if not, get
-- the corresponding header from the VolatileDB and store it in the cache.
--
-- PRECONDITION: the header (block) must exist in the VolatileDB.
getKnownHeaderThroughCache
  :: (MonadThrow m, HasHeader blk)
  => VolatileDB m blk
  -> HeaderHash blk
  -> StateT (Map (HeaderHash blk) (Header blk)) m (Header blk)
getKnownHeaderThroughCache :: VolatileDB m blk
-> HeaderHash blk
-> StateT (Map (HeaderHash blk) (Header blk)) m (Header blk)
getKnownHeaderThroughCache VolatileDB m blk
volatileDB HeaderHash blk
hash = (Map (HeaderHash blk) (Header blk) -> Maybe (Header blk))
-> StateT
     (Map (HeaderHash blk) (Header blk)) m (Maybe (Header blk))
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets (HeaderHash blk
-> Map (HeaderHash blk) (Header blk) -> Maybe (Header blk)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup HeaderHash blk
hash) StateT (Map (HeaderHash blk) (Header blk)) m (Maybe (Header blk))
-> (Maybe (Header blk)
    -> StateT (Map (HeaderHash blk) (Header blk)) m (Header blk))
-> StateT (Map (HeaderHash blk) (Header blk)) m (Header blk)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just Header blk
hdr -> Header blk
-> StateT (Map (HeaderHash blk) (Header blk)) m (Header blk)
forall (m :: * -> *) a. Monad m => a -> m a
return Header blk
hdr
    Maybe (Header blk)
Nothing  -> do
      Header blk
hdr <- m (Header blk)
-> StateT (Map (HeaderHash blk) (Header blk)) m (Header blk)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Header blk)
 -> StateT (Map (HeaderHash blk) (Header blk)) m (Header blk))
-> m (Header blk)
-> StateT (Map (HeaderHash blk) (Header blk)) m (Header blk)
forall a b. (a -> b) -> a -> b
$ VolatileDB m blk
-> BlockComponent blk (Header blk)
-> HeaderHash blk
-> m (Header blk)
forall (m :: * -> *) blk b.
(MonadThrow m, HasHeader blk) =>
VolatileDB m blk -> BlockComponent blk b -> HeaderHash blk -> m b
VolatileDB.getKnownBlockComponent VolatileDB m blk
volatileDB BlockComponent blk (Header blk)
forall blk. BlockComponent blk (Header blk)
GetHeader HeaderHash blk
hash
      (Map (HeaderHash blk) (Header blk)
 -> Map (HeaderHash blk) (Header blk))
-> StateT (Map (HeaderHash blk) (Header blk)) m ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (HeaderHash blk
-> Header blk
-> Map (HeaderHash blk) (Header blk)
-> Map (HeaderHash blk) (Header blk)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert HeaderHash blk
hash Header blk
hdr)
      Header blk
-> StateT (Map (HeaderHash blk) (Header blk)) m (Header blk)
forall (m :: * -> *) a. Monad m => a -> m a
return Header blk
hdr

-- | Environment used by 'chainSelection' and related functions.
data ChainSelEnv m blk = ChainSelEnv
    { ChainSelEnv m blk -> LgrDB m blk
lgrDB             :: LgrDB m blk
    , ChainSelEnv m blk -> TraceValidationEvent blk -> m ()
trace             :: TraceValidationEvent blk -> m ()
    , ChainSelEnv m blk -> TopLevelConfig blk
cfg               :: TopLevelConfig blk
    , ChainSelEnv m blk
-> StrictTVar m (WithFingerprint (InvalidBlocks blk))
varInvalid        :: StrictTVar m (WithFingerprint (InvalidBlocks blk))
    , ChainSelEnv m blk -> StrictTVar m (FutureBlocks blk)
varFutureBlocks   :: StrictTVar m (FutureBlocks blk)
    , ChainSelEnv m blk -> CheckInFuture m blk
futureCheck       :: CheckInFuture m blk
    , ChainSelEnv m blk -> BlockCache blk
blockCache        :: BlockCache blk
    , ChainSelEnv m blk -> ChainAndLedger blk
curChainAndLedger :: ChainAndLedger blk
    }

-- | Perform chain selection with the given candidates. If a validated
-- candidate was chosen to replace the current chain, return it along with the
-- corresponding ledger.
--
-- PRECONDITION: all candidates must be preferred over the current chain.
--
-- PRECONDITION: the candidate chain diffs must fit on the (given) current
-- chain.
chainSelection
  :: forall m blk.
     ( IOLike m
     , LedgerSupportsProtocol blk
     , HasCallStack
     )
  => ChainSelEnv m blk
  -> NonEmpty (ChainDiff (Header blk))
  -> m (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
     -- ^ The (valid) chain diff and corresponding LedgerDB that was selected,
     -- or 'Nothing' if there is no valid chain diff preferred over the
     -- current chain.
chainSelection :: ChainSelEnv m blk
-> NonEmpty (ChainDiff (Header blk))
-> m (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
chainSelection ChainSelEnv m blk
chainSelEnv NonEmpty (ChainDiff (Header blk))
chainDiffs =
    Bool
-> m (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
-> m (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
forall a. HasCallStack => Bool -> a -> a
assert ((ChainDiff (Header blk) -> Bool)
-> NonEmpty (ChainDiff (Header blk)) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (TopLevelConfig blk
-> AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk)
-> Bool
forall blk.
BlockSupportsProtocol blk =>
TopLevelConfig blk
-> AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk)
-> Bool
preferAnchoredCandidate TopLevelConfig blk
cfg AnchoredFragment (Header blk)
curChain (AnchoredFragment (Header blk) -> Bool)
-> (ChainDiff (Header blk) -> AnchoredFragment (Header blk))
-> ChainDiff (Header blk)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainDiff (Header blk) -> AnchoredFragment (Header blk)
forall b. ChainDiff b -> AnchoredFragment b
Diff.getSuffix)
                NonEmpty (ChainDiff (Header blk))
chainDiffs) (m (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
 -> m (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk))))
-> m (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
-> m (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
forall a b. (a -> b) -> a -> b
$
    Bool
-> m (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
-> m (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
forall a. HasCallStack => Bool -> a -> a
assert ((ChainDiff (Header blk) -> Bool)
-> NonEmpty (ChainDiff (Header blk)) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Maybe (AnchoredFragment (Header blk)) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (AnchoredFragment (Header blk)) -> Bool)
-> (ChainDiff (Header blk)
    -> Maybe (AnchoredFragment (Header blk)))
-> ChainDiff (Header blk)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredFragment (Header blk)
-> ChainDiff (Header blk) -> Maybe (AnchoredFragment (Header blk))
forall b.
HasHeader b =>
AnchoredFragment b -> ChainDiff b -> Maybe (AnchoredFragment b)
Diff.apply AnchoredFragment (Header blk)
curChain)
                NonEmpty (ChainDiff (Header blk))
chainDiffs) (m (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
 -> m (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk))))
-> m (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
-> m (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
forall a b. (a -> b) -> a -> b
$
    [ChainDiff (Header blk)]
-> m (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
go ([ChainDiff (Header blk)] -> [ChainDiff (Header blk)]
sortCandidates (NonEmpty (ChainDiff (Header blk)) -> [ChainDiff (Header blk)]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty (ChainDiff (Header blk))
chainDiffs))
  where
    ChainSelEnv { TopLevelConfig blk
cfg :: TopLevelConfig blk
cfg :: forall (m :: * -> *) blk. ChainSelEnv m blk -> TopLevelConfig blk
cfg, ChainAndLedger blk
curChainAndLedger :: ChainAndLedger blk
curChainAndLedger :: forall (m :: * -> *) blk. ChainSelEnv m blk -> ChainAndLedger blk
curChainAndLedger, StrictTVar m (WithFingerprint (InvalidBlocks blk))
varInvalid :: StrictTVar m (WithFingerprint (InvalidBlocks blk))
varInvalid :: forall (m :: * -> *) blk.
ChainSelEnv m blk
-> StrictTVar m (WithFingerprint (InvalidBlocks blk))
varInvalid, StrictTVar m (FutureBlocks blk)
varFutureBlocks :: StrictTVar m (FutureBlocks blk)
varFutureBlocks :: forall (m :: * -> *) blk.
ChainSelEnv m blk -> StrictTVar m (FutureBlocks blk)
varFutureBlocks } =
      ChainSelEnv m blk
chainSelEnv

    curChain :: AnchoredFragment (Header blk)
curChain = ChainAndLedger blk -> AnchoredFragment (Header blk)
forall b l. ValidatedFragment b l -> AnchoredFragment b
VF.validatedFragment ChainAndLedger blk
curChainAndLedger

    sortCandidates :: [ChainDiff (Header blk)] -> [ChainDiff (Header blk)]
    sortCandidates :: [ChainDiff (Header blk)] -> [ChainDiff (Header blk)]
sortCandidates =
      (ChainDiff (Header blk) -> ChainDiff (Header blk) -> Ordering)
-> [ChainDiff (Header blk)] -> [ChainDiff (Header blk)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((AnchoredFragment (Header blk)
 -> AnchoredFragment (Header blk) -> Ordering)
-> AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk)
-> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip (TopLevelConfig blk
-> AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk)
-> Ordering
forall blk.
(BlockSupportsProtocol blk, HasCallStack) =>
TopLevelConfig blk
-> AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk)
-> Ordering
compareAnchoredCandidates TopLevelConfig blk
cfg) (AnchoredFragment (Header blk)
 -> AnchoredFragment (Header blk) -> Ordering)
-> (ChainDiff (Header blk) -> AnchoredFragment (Header blk))
-> ChainDiff (Header blk)
-> ChainDiff (Header blk)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ChainDiff (Header blk) -> AnchoredFragment (Header blk)
forall b. ChainDiff b -> AnchoredFragment b
Diff.getSuffix)

    -- 1. Take the first candidate from the list of sorted candidates
    -- 2. Validate it
    --    - If it is invalid -> discard it and go to 1 with the rest of the
    --      list.
    --    - If it is valid and has the same tip -> return it
    --    - If it is valid, but is a prefix of the original ->
    --        add it to the list, sort it and go to 1. See the comment
    --        [Ouroboros] below.
    go ::
         [ChainDiff (Header blk)]
      -> m (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
    go :: [ChainDiff (Header blk)]
-> m (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
go []            = Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk))
-> m (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk))
forall a. Maybe a
Nothing
    go (ChainDiff (Header blk)
candidate:[ChainDiff (Header blk)]
candidates0) =
      ChainSelEnv m blk
-> ChainDiff (Header blk) -> m (ValidationResult blk)
forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsProtocol blk, HasCallStack) =>
ChainSelEnv m blk
-> ChainDiff (Header blk) -> m (ValidationResult blk)
validateCandidate ChainSelEnv m blk
chainSelEnv ChainDiff (Header blk)
candidate m (ValidationResult blk)
-> (ValidationResult blk
    -> m (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk))))
-> m (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        ValidationResult blk
InsufficientSuffix -> do
          [ChainDiff (Header blk)]
candidates1 <- [ChainDiff (Header blk)] -> m [ChainDiff (Header blk)]
truncateRejectedBlocks [ChainDiff (Header blk)]
candidates0
          [ChainDiff (Header blk)]
-> m (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
go ([ChainDiff (Header blk)] -> [ChainDiff (Header blk)]
sortCandidates [ChainDiff (Header blk)]
candidates1)
        FullyValid validatedCandidate :: ValidatedChainDiff (Header blk) (LedgerDB' blk)
validatedCandidate@(ValidatedChainDiff ChainDiff (Header blk)
candidate' LedgerDB' blk
_) ->
          -- The entire candidate is valid
          Bool
-> m (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
-> m (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
forall a. HasCallStack => Bool -> a -> a
assert (ChainDiff (Header blk) -> Point (Header blk)
forall b. HasHeader b => ChainDiff b -> Point b
Diff.getTip ChainDiff (Header blk)
candidate Point (Header blk) -> Point (Header blk) -> Bool
forall a. Eq a => a -> a -> Bool
== ChainDiff (Header blk) -> Point (Header blk)
forall b. HasHeader b => ChainDiff b -> Point b
Diff.getTip ChainDiff (Header blk)
candidate') (m (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
 -> m (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk))))
-> m (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
-> m (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
forall a b. (a -> b) -> a -> b
$
          Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk))
-> m (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk))
 -> m (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk))))
-> Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk))
-> m (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
forall a b. (a -> b) -> a -> b
$ ValidatedChainDiff (Header blk) (LedgerDB' blk)
-> Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk))
forall a. a -> Maybe a
Just ValidatedChainDiff (Header blk) (LedgerDB' blk)
validatedCandidate
        ValidPrefix ChainDiff (Header blk)
candidate' -> do
          -- Prefix of the candidate because it contained rejected blocks
          -- (invalid blocks and/or blocks from the future). Note that the
          -- spec says go back to candidate selection, see [^whyGoBack],
          -- because there might still be some candidates that contain the
          -- same rejected block. To simplify the control flow, we do it
          -- differently: instead of recomputing the candidates taking
          -- rejected blocks into account, we just truncate the remaining
          -- candidates that contain rejected blocks.
          [ChainDiff (Header blk)]
candidates1 <- [ChainDiff (Header blk)] -> m [ChainDiff (Header blk)]
truncateRejectedBlocks [ChainDiff (Header blk)]
candidates0
          -- Only include the prefix if it is still preferred over the current
          -- chain. When the candidate is now empty because of the truncation,
          -- it will be dropped here, as it will not be preferred over the
          -- current chain.
          let candidates2 :: [ChainDiff (Header blk)]
candidates2
                | TopLevelConfig blk
-> AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk)
-> Bool
forall blk.
BlockSupportsProtocol blk =>
TopLevelConfig blk
-> AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk)
-> Bool
preferAnchoredCandidate TopLevelConfig blk
cfg AnchoredFragment (Header blk)
curChain (ChainDiff (Header blk) -> AnchoredFragment (Header blk)
forall b. ChainDiff b -> AnchoredFragment b
Diff.getSuffix ChainDiff (Header blk)
candidate')
                = ChainDiff (Header blk)
candidate'ChainDiff (Header blk)
-> [ChainDiff (Header blk)] -> [ChainDiff (Header blk)]
forall a. a -> [a] -> [a]
:[ChainDiff (Header blk)]
candidates1
                | Bool
otherwise
                = [ChainDiff (Header blk)]
candidates1
          [ChainDiff (Header blk)]
-> m (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
go ([ChainDiff (Header blk)] -> [ChainDiff (Header blk)]
sortCandidates [ChainDiff (Header blk)]
candidates2)

    -- | Truncate the given (remaining) candidates that contain rejected
    -- blocks. Discard them if they are truncated so much that they are no
    -- longer preferred over the current chain.
    --
    -- A block is rejected if:
    --
    -- * It is invalid (present in 'varInvalid', i.e., 'cdbInvalid').
    -- * It is from the future (present in 'varFutureBlocks', i.e.,
    --   'cdbFutureBlocks').
    truncateRejectedBlocks ::
         [ChainDiff (Header blk)]
      -> m [ChainDiff (Header blk)]
    truncateRejectedBlocks :: [ChainDiff (Header blk)] -> m [ChainDiff (Header blk)]
truncateRejectedBlocks [ChainDiff (Header blk)]
cands = do
      (WithFingerprint (InvalidBlocks blk)
invalid, FutureBlocks blk
futureBlocks) <-
        STM m (WithFingerprint (InvalidBlocks blk), FutureBlocks blk)
-> m (WithFingerprint (InvalidBlocks blk), FutureBlocks blk)
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (WithFingerprint (InvalidBlocks blk), FutureBlocks blk)
 -> m (WithFingerprint (InvalidBlocks blk), FutureBlocks blk))
-> STM m (WithFingerprint (InvalidBlocks blk), FutureBlocks blk)
-> m (WithFingerprint (InvalidBlocks blk), FutureBlocks blk)
forall a b. (a -> b) -> a -> b
$ (,) (WithFingerprint (InvalidBlocks blk)
 -> FutureBlocks blk
 -> (WithFingerprint (InvalidBlocks blk), FutureBlocks blk))
-> STM m (WithFingerprint (InvalidBlocks blk))
-> STM
     m
     (FutureBlocks blk
      -> (WithFingerprint (InvalidBlocks blk), FutureBlocks blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m (WithFingerprint (InvalidBlocks blk))
-> STM m (WithFingerprint (InvalidBlocks blk))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (WithFingerprint (InvalidBlocks blk))
varInvalid STM
  m
  (FutureBlocks blk
   -> (WithFingerprint (InvalidBlocks blk), FutureBlocks blk))
-> STM m (FutureBlocks blk)
-> STM m (WithFingerprint (InvalidBlocks blk), FutureBlocks blk)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StrictTVar m (FutureBlocks blk) -> STM m (FutureBlocks blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (FutureBlocks blk)
varFutureBlocks
      let isRejected :: Header blk -> Bool
isRejected Header blk
hdr =
               HeaderHash blk -> InvalidBlocks blk -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member (Header blk -> HeaderHash blk
forall blk. HasHeader (Header blk) => Header blk -> HeaderHash blk
headerHash Header blk
hdr) (WithFingerprint (InvalidBlocks blk) -> InvalidBlocks blk
forall a. WithFingerprint a -> a
forgetFingerprint WithFingerprint (InvalidBlocks blk)
invalid)
            Bool -> Bool -> Bool
|| HeaderHash blk -> FutureBlocks blk -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member (Header blk -> HeaderHash blk
forall blk. HasHeader (Header blk) => Header blk -> HeaderHash blk
headerHash Header blk
hdr) FutureBlocks blk
futureBlocks
      [ChainDiff (Header blk)] -> m [ChainDiff (Header blk)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([ChainDiff (Header blk)] -> m [ChainDiff (Header blk)])
-> [ChainDiff (Header blk)] -> m [ChainDiff (Header blk)]
forall a b. (a -> b) -> a -> b
$ (ChainDiff (Header blk) -> Bool)
-> [ChainDiff (Header blk)] -> [ChainDiff (Header blk)]
forall a. (a -> Bool) -> [a] -> [a]
filter (TopLevelConfig blk
-> AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk)
-> Bool
forall blk.
BlockSupportsProtocol blk =>
TopLevelConfig blk
-> AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk)
-> Bool
preferAnchoredCandidate TopLevelConfig blk
cfg AnchoredFragment (Header blk)
curChain (AnchoredFragment (Header blk) -> Bool)
-> (ChainDiff (Header blk) -> AnchoredFragment (Header blk))
-> ChainDiff (Header blk)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainDiff (Header blk) -> AnchoredFragment (Header blk)
forall b. ChainDiff b -> AnchoredFragment b
Diff.getSuffix)
             ([ChainDiff (Header blk)] -> [ChainDiff (Header blk)])
-> [ChainDiff (Header blk)] -> [ChainDiff (Header blk)]
forall a b. (a -> b) -> a -> b
$ (ChainDiff (Header blk) -> ChainDiff (Header blk))
-> [ChainDiff (Header blk)] -> [ChainDiff (Header blk)]
forall a b. (a -> b) -> [a] -> [b]
map ((Header blk -> Bool)
-> ChainDiff (Header blk) -> ChainDiff (Header blk)
forall b. HasHeader b => (b -> Bool) -> ChainDiff b -> ChainDiff b
Diff.takeWhileOldest (Bool -> Bool
not (Bool -> Bool) -> (Header blk -> Bool) -> Header blk -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header blk -> Bool
isRejected)) [ChainDiff (Header blk)]
cands

    -- [Ouroboros]
    --
    -- Ouroboros says that when we are given an invalid chain by a peer, we
    -- should reject that peer's chain. However, since we're throwing all
    -- blocks together in the ChainDB, we can't tell which block or which
    -- chain came from which peer, so we can't simply reject a peer's chain.
    --
    -- It might be that a good peer gave us a valid chain, but another peer
    -- gave us an invalid block that fits onto the chain of the good peer. In
    -- that case, we do still want to adopt the chain of the good peer, which
    -- is a prefix of the chain that we constructed using all the blocks we
    -- found in the VolatileDB, including the invalid block.
    --
    -- This is the reason why we still take valid prefixes of a invalid chains
    -- into account during chain selection: they might correspond to the good
    -- peer's valid chain.

-- | Result of 'validateCandidate'.
data ValidationResult blk =
      -- | The entire candidate fragment was valid. No blocks were from the
      -- future.
      FullyValid (ValidatedChainDiff (Header blk) (LedgerDB' blk))

      -- | The candidate fragment contained invalid blocks and/or blocks from
      -- the future that had to be truncated from the fragment.
    | ValidPrefix (ChainDiff (Header blk))

      -- | After truncating the invalid blocks or blocks from the future from
      -- the 'ChainDiff', it no longer contains enough blocks in its suffix to
      -- compensate for the number of blocks it wants to roll back.
    | InsufficientSuffix

-- | Validate a candidate by applying its blocks to the ledger, and return a
-- 'ValidatedChainDiff' for it, i.e., a chain diff along with a ledger
-- corresponding to its tip (the most recent block).
--
-- PRECONDITION: the candidate (chain diff) must fit onto the given current
-- chain.
--
-- If all blocks in the fragment are valid, then the chain diff in the
-- returned 'ValidatedChainDiff' is the same as the given candidate chain
-- diff.
--
-- If a block in the fragment is invalid, then the fragment in the returned
-- 'ValidatedChainDiff' is a prefix of the given candidate chain diff (upto
-- the last valid block).
ledgerValidateCandidate
  :: forall m blk.
     ( IOLike m
     , LedgerSupportsProtocol blk
     , HasCallStack
     )
  => ChainSelEnv m blk
  -> ChainDiff (Header blk)
  -> m (ValidatedChainDiff (Header blk) (LedgerDB' blk))
ledgerValidateCandidate :: ChainSelEnv m blk
-> ChainDiff (Header blk)
-> m (ValidatedChainDiff (Header blk) (LedgerDB' blk))
ledgerValidateCandidate ChainSelEnv m blk
chainSelEnv chainDiff :: ChainDiff (Header blk)
chainDiff@(ChainDiff Word64
rollback AnchoredFragment (Header blk)
suffix) =
    LgrDB m blk
-> LedgerDB' blk
-> BlockCache blk
-> Word64
-> [Header blk]
-> m (ValidateResult blk)
forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsProtocol blk, HasCallStack) =>
LgrDB m blk
-> LedgerDB' blk
-> BlockCache blk
-> Word64
-> [Header blk]
-> m (ValidateResult blk)
LgrDB.validate LgrDB m blk
lgrDB LedgerDB' blk
curLedger BlockCache blk
blockCache Word64
rollback [Header blk]
newBlocks m (ValidateResult blk)
-> (ValidateResult blk
    -> m (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
-> m (ValidatedChainDiff (Header blk) (LedgerDB' blk))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      LgrDB.ValidateExceededRollBack {} ->
        -- Impossible: we asked the LgrDB to roll back past the immutable tip,
        -- which is impossible, since the candidates we construct must connect
        -- to the immutable tip.
        [Char] -> m (ValidatedChainDiff (Header blk) (LedgerDB' blk))
forall a. HasCallStack => [Char] -> a
error [Char]
"found candidate requiring rolling back past the immutable tip"

      LgrDB.ValidateLedgerError (LgrDB.AnnLedgerError LedgerDB' blk
ledger' RealPoint blk
pt LedgerErr (ExtLedgerState blk)
e) -> do
        let lastValid :: Point blk
lastValid = LedgerDB' blk -> Point blk
forall blk. UpdateLedger blk => LedgerDB' blk -> Point blk
LgrDB.currentPoint LedgerDB' blk
ledger'
            chainDiff' :: ChainDiff (Header blk)
chainDiff' = Point (Header blk)
-> ChainDiff (Header blk) -> ChainDiff (Header blk)
forall b.
(HasHeader b, HasCallStack) =>
Point b -> ChainDiff b -> ChainDiff b
Diff.truncate (Point blk -> Point (Header blk)
forall b b'.
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint Point blk
lastValid) ChainDiff (Header blk)
chainDiff
        TraceValidationEvent blk -> m ()
trace (ExtValidationError blk -> RealPoint blk -> TraceValidationEvent blk
forall blk.
ExtValidationError blk -> RealPoint blk -> TraceValidationEvent blk
InvalidBlock LedgerErr (ExtLedgerState blk)
ExtValidationError blk
e RealPoint blk
pt)
        ExtValidationError blk -> RealPoint blk -> m ()
addInvalidBlock LedgerErr (ExtLedgerState blk)
ExtValidationError blk
e RealPoint blk
pt
        TraceValidationEvent blk -> m ()
trace (AnchoredFragment (Header blk) -> TraceValidationEvent blk
forall blk.
AnchoredFragment (Header blk) -> TraceValidationEvent blk
ValidCandidate (ChainDiff (Header blk) -> AnchoredFragment (Header blk)
forall b. ChainDiff b -> AnchoredFragment b
Diff.getSuffix ChainDiff (Header blk)
chainDiff'))
        ValidatedChainDiff (Header blk) (LedgerDB' blk)
-> m (ValidatedChainDiff (Header blk) (LedgerDB' blk))
forall (m :: * -> *) a. Monad m => a -> m a
return (ValidatedChainDiff (Header blk) (LedgerDB' blk)
 -> m (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
-> ValidatedChainDiff (Header blk) (LedgerDB' blk)
-> m (ValidatedChainDiff (Header blk) (LedgerDB' blk))
forall a b. (a -> b) -> a -> b
$ ChainDiff (Header blk)
-> LedgerDB' blk -> ValidatedChainDiff (Header blk) (LedgerDB' blk)
forall b l.
(IsLedger l, HasHeader b, HeaderHash l ~ HeaderHash b,
 HasCallStack) =>
ChainDiff b -> l -> ValidatedChainDiff b l
ValidatedDiff.new ChainDiff (Header blk)
chainDiff' LedgerDB' blk
ledger'

      LgrDB.ValidateSuccessful LedgerDB' blk
ledger' -> do
        TraceValidationEvent blk -> m ()
trace (AnchoredFragment (Header blk) -> TraceValidationEvent blk
forall blk.
AnchoredFragment (Header blk) -> TraceValidationEvent blk
ValidCandidate AnchoredFragment (Header blk)
suffix)
        ValidatedChainDiff (Header blk) (LedgerDB' blk)
-> m (ValidatedChainDiff (Header blk) (LedgerDB' blk))
forall (m :: * -> *) a. Monad m => a -> m a
return (ValidatedChainDiff (Header blk) (LedgerDB' blk)
 -> m (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
-> ValidatedChainDiff (Header blk) (LedgerDB' blk)
-> m (ValidatedChainDiff (Header blk) (LedgerDB' blk))
forall a b. (a -> b) -> a -> b
$ ChainDiff (Header blk)
-> LedgerDB' blk -> ValidatedChainDiff (Header blk) (LedgerDB' blk)
forall b l.
(IsLedger l, HasHeader b, HeaderHash l ~ HeaderHash b,
 HasCallStack) =>
ChainDiff b -> l -> ValidatedChainDiff b l
ValidatedDiff.new ChainDiff (Header blk)
chainDiff LedgerDB' blk
ledger'
  where
    ChainSelEnv { LgrDB m blk
lgrDB :: LgrDB m blk
lgrDB :: forall (m :: * -> *) blk. ChainSelEnv m blk -> LgrDB m blk
lgrDB, TraceValidationEvent blk -> m ()
trace :: TraceValidationEvent blk -> m ()
trace :: forall (m :: * -> *) blk.
ChainSelEnv m blk -> TraceValidationEvent blk -> m ()
trace, ChainAndLedger blk
curChainAndLedger :: ChainAndLedger blk
curChainAndLedger :: forall (m :: * -> *) blk. ChainSelEnv m blk -> ChainAndLedger blk
curChainAndLedger, BlockCache blk
blockCache :: BlockCache blk
blockCache :: forall (m :: * -> *) blk. ChainSelEnv m blk -> BlockCache blk
blockCache, StrictTVar m (WithFingerprint (InvalidBlocks blk))
varInvalid :: StrictTVar m (WithFingerprint (InvalidBlocks blk))
varInvalid :: forall (m :: * -> *) blk.
ChainSelEnv m blk
-> StrictTVar m (WithFingerprint (InvalidBlocks blk))
varInvalid } =
      ChainSelEnv m blk
chainSelEnv

    curLedger :: LedgerDB' blk
    curLedger :: LedgerDB' blk
curLedger = ChainAndLedger blk -> LedgerDB' blk
forall b l. ValidatedFragment b l -> l
VF.validatedLedger ChainAndLedger blk
curChainAndLedger

    newBlocks :: [Header blk]
    newBlocks :: [Header blk]
newBlocks = AnchoredFragment (Header blk) -> [Header blk]
forall block. AnchoredFragment block -> [block]
AF.toOldestFirst AnchoredFragment (Header blk)
suffix

    -- | Record the invalid block in 'cdbInvalid' and change its fingerprint.
    addInvalidBlock :: ExtValidationError blk -> RealPoint blk -> m ()
    addInvalidBlock :: ExtValidationError blk -> RealPoint blk -> m ()
addInvalidBlock ExtValidationError blk
e (RealPoint SlotNo
slot HeaderHash blk
hash) = STM m () -> m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$
      StrictTVar m (WithFingerprint (InvalidBlocks blk))
-> (WithFingerprint (InvalidBlocks blk)
    -> WithFingerprint (InvalidBlocks blk))
-> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar StrictTVar m (WithFingerprint (InvalidBlocks blk))
varInvalid ((WithFingerprint (InvalidBlocks blk)
  -> WithFingerprint (InvalidBlocks blk))
 -> STM m ())
-> (WithFingerprint (InvalidBlocks blk)
    -> WithFingerprint (InvalidBlocks blk))
-> STM m ()
forall a b. (a -> b) -> a -> b
$ \(WithFingerprint InvalidBlocks blk
invalid Fingerprint
fp) ->
        InvalidBlocks blk
-> Fingerprint -> WithFingerprint (InvalidBlocks blk)
forall a. a -> Fingerprint -> WithFingerprint a
WithFingerprint
          (HeaderHash blk
-> InvalidBlockInfo blk -> InvalidBlocks blk -> InvalidBlocks blk
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert HeaderHash blk
hash (InvalidBlockReason blk -> SlotNo -> InvalidBlockInfo blk
forall blk.
InvalidBlockReason blk -> SlotNo -> InvalidBlockInfo blk
InvalidBlockInfo (ExtValidationError blk -> InvalidBlockReason blk
forall blk. ExtValidationError blk -> InvalidBlockReason blk
ValidationError ExtValidationError blk
e) SlotNo
slot) InvalidBlocks blk
invalid)
          (Fingerprint -> Fingerprint
forall a. Enum a => a -> a
succ Fingerprint
fp)

-- | Truncate any future headers from the candidate 'ValidatedChainDiff'.
--
-- Future headers that don't exceed the clock skew
-- ('inFutureExceedsClockSkew') are added to 'cdbFutureBlocks'.
--
-- Future headers that exceed the clock skew are added to 'cdbInvalid' with
-- 'InFutureExceedsClockSkew' as the reason.
--
-- When truncation happened, 'Left' is returned, otherwise 'Right'.
futureCheckCandidate
  :: forall m blk. (IOLike m, LedgerSupportsProtocol blk)
  => ChainSelEnv m blk
  -> ValidatedChainDiff (Header blk) (LedgerDB' blk)
  -> m (Either (ChainDiff (Header blk))
               (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
futureCheckCandidate :: ChainSelEnv m blk
-> ValidatedChainDiff (Header blk) (LedgerDB' blk)
-> m (Either
        (ChainDiff (Header blk))
        (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
futureCheckCandidate ChainSelEnv m blk
chainSelEnv ValidatedChainDiff (Header blk) (LedgerDB' blk)
validatedChainDiff =
    CheckInFuture m blk
-> ValidatedFragment (Header blk) (LedgerState blk)
-> m (AnchoredFragment (Header blk), [InFuture blk])
forall (m :: * -> *) blk.
CheckInFuture m blk
-> ValidatedFragment (Header blk) (LedgerState blk)
-> m (AnchoredFragment (Header blk), [InFuture blk])
checkInFuture CheckInFuture m blk
futureCheck ValidatedFragment (Header blk) (LedgerState blk)
validatedSuffix m (AnchoredFragment (Header blk), [InFuture blk])
-> ((AnchoredFragment (Header blk), [InFuture blk])
    -> m (Either
            (ChainDiff (Header blk))
            (ValidatedChainDiff (Header blk) (LedgerDB' blk))))
-> m (Either
        (ChainDiff (Header blk))
        (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case

      (AnchoredFragment (Header blk)
suffix', []) ->
        -- If no headers are in the future, then the fragment must be untouched
        Bool
-> m (Either
        (ChainDiff (Header blk))
        (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
-> m (Either
        (ChainDiff (Header blk))
        (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
forall a. HasCallStack => Bool -> a -> a
assert (AnchoredFragment (Header blk) -> Point (Header blk)
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.headPoint AnchoredFragment (Header blk)
suffix Point (Header blk) -> Point (Header blk) -> Bool
forall a. Eq a => a -> a -> Bool
== AnchoredFragment (Header blk) -> Point (Header blk)
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.headPoint AnchoredFragment (Header blk)
suffix') (m (Either
      (ChainDiff (Header blk))
      (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
 -> m (Either
         (ChainDiff (Header blk))
         (ValidatedChainDiff (Header blk) (LedgerDB' blk))))
-> m (Either
        (ChainDiff (Header blk))
        (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
-> m (Either
        (ChainDiff (Header blk))
        (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
forall a b. (a -> b) -> a -> b
$
        Either
  (ChainDiff (Header blk))
  (ValidatedChainDiff (Header blk) (LedgerDB' blk))
-> m (Either
        (ChainDiff (Header blk))
        (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   (ChainDiff (Header blk))
   (ValidatedChainDiff (Header blk) (LedgerDB' blk))
 -> m (Either
         (ChainDiff (Header blk))
         (ValidatedChainDiff (Header blk) (LedgerDB' blk))))
-> Either
     (ChainDiff (Header blk))
     (ValidatedChainDiff (Header blk) (LedgerDB' blk))
-> m (Either
        (ChainDiff (Header blk))
        (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
forall a b. (a -> b) -> a -> b
$ ValidatedChainDiff (Header blk) (LedgerDB' blk)
-> Either
     (ChainDiff (Header blk))
     (ValidatedChainDiff (Header blk) (LedgerDB' blk))
forall a b. b -> Either a b
Right ValidatedChainDiff (Header blk) (LedgerDB' blk)
validatedChainDiff

      (AnchoredFragment (Header blk)
suffix', [InFuture blk]
inFuture) -> do
        let ([InFuture blk]
exceedClockSkew, [InFuture blk]
inNearFuture) =
              (InFuture blk -> Bool)
-> [InFuture blk] -> ([InFuture blk], [InFuture blk])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition InFuture blk -> Bool
forall blk. InFuture blk -> Bool
InFuture.inFutureExceedsClockSkew [InFuture blk]
inFuture
        -- Record future blocks
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([InFuture blk] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [InFuture blk]
inNearFuture) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
          let futureHeaders :: [Header blk]
futureHeaders = InFuture blk -> Header blk
forall blk. InFuture blk -> Header blk
InFuture.inFutureHeader (InFuture blk -> Header blk) -> [InFuture blk] -> [Header blk]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [InFuture blk]
inNearFuture
              futureBlocks :: Map (HeaderHash blk) (Header blk)
futureBlocks  = [(HeaderHash blk, Header blk)] -> Map (HeaderHash blk) (Header blk)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
                [ (Header blk -> HeaderHash blk
forall blk. HasHeader (Header blk) => Header blk -> HeaderHash blk
headerHash Header blk
hdr, Header blk
hdr) | Header blk
hdr <- [Header blk]
futureHeaders ]
          STM m () -> m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ StrictTVar m (Map (HeaderHash blk) (Header blk))
-> (Map (HeaderHash blk) (Header blk)
    -> Map (HeaderHash blk) (Header blk))
-> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar StrictTVar m (Map (HeaderHash blk) (Header blk))
varFutureBlocks ((Map (HeaderHash blk) (Header blk)
  -> Map (HeaderHash blk) (Header blk))
 -> STM m ())
-> (Map (HeaderHash blk) (Header blk)
    -> Map (HeaderHash blk) (Header blk))
-> STM m ()
forall a b. (a -> b) -> a -> b
$ (Map (HeaderHash blk) (Header blk)
 -> Map (HeaderHash blk) (Header blk)
 -> Map (HeaderHash blk) (Header blk))
-> Map (HeaderHash blk) (Header blk)
-> Map (HeaderHash blk) (Header blk)
-> Map (HeaderHash blk) (Header blk)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Map (HeaderHash blk) (Header blk)
-> Map (HeaderHash blk) (Header blk)
-> Map (HeaderHash blk) (Header blk)
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map (HeaderHash blk) (Header blk)
futureBlocks
          -- Trace the original @suffix@, as it contains the headers from the
          -- future
          TraceValidationEvent blk -> m ()
trace (TraceValidationEvent blk -> m ())
-> TraceValidationEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$ AnchoredFragment (Header blk)
-> [Header blk] -> TraceValidationEvent blk
forall blk.
AnchoredFragment (Header blk)
-> [Header blk] -> TraceValidationEvent blk
CandidateContainsFutureBlocks AnchoredFragment (Header blk)
suffix [Header blk]
futureHeaders

        -- Record any blocks exceeding the clock skew as invalid
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([InFuture blk] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [InFuture blk]
exceedClockSkew) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
          let invalidHeaders :: [Header blk]
invalidHeaders = InFuture blk -> Header blk
forall blk. InFuture blk -> Header blk
InFuture.inFutureHeader (InFuture blk -> Header blk) -> [InFuture blk] -> [Header blk]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [InFuture blk]
exceedClockSkew
              invalidBlocks :: Map (HeaderHash blk) (InvalidBlockInfo blk)
invalidBlocks  = [(HeaderHash blk, InvalidBlockInfo blk)]
-> Map (HeaderHash blk) (InvalidBlockInfo blk)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
                [ (Header blk -> HeaderHash blk
forall blk. HasHeader (Header blk) => Header blk -> HeaderHash blk
headerHash Header blk
hdr, InvalidBlockInfo blk
info)
                | Header blk
hdr <- [Header blk]
invalidHeaders
                , let reason :: InvalidBlockReason blk
reason = RealPoint blk -> InvalidBlockReason blk
forall blk. RealPoint blk -> InvalidBlockReason blk
InFutureExceedsClockSkew (Header blk -> RealPoint blk
forall blk. HasHeader (Header blk) => Header blk -> RealPoint blk
headerRealPoint Header blk
hdr)
                      info :: InvalidBlockInfo blk
info   = InvalidBlockReason blk -> SlotNo -> InvalidBlockInfo blk
forall blk.
InvalidBlockReason blk -> SlotNo -> InvalidBlockInfo blk
InvalidBlockInfo InvalidBlockReason blk
reason (Header blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot Header blk
hdr)
                ]
          STM m () -> m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ StrictTVar
  m (WithFingerprint (Map (HeaderHash blk) (InvalidBlockInfo blk)))
-> (WithFingerprint (Map (HeaderHash blk) (InvalidBlockInfo blk))
    -> WithFingerprint (Map (HeaderHash blk) (InvalidBlockInfo blk)))
-> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar StrictTVar
  m (WithFingerprint (Map (HeaderHash blk) (InvalidBlockInfo blk)))
varInvalid ((WithFingerprint (Map (HeaderHash blk) (InvalidBlockInfo blk))
  -> WithFingerprint (Map (HeaderHash blk) (InvalidBlockInfo blk)))
 -> STM m ())
-> (WithFingerprint (Map (HeaderHash blk) (InvalidBlockInfo blk))
    -> WithFingerprint (Map (HeaderHash blk) (InvalidBlockInfo blk)))
-> STM m ()
forall a b. (a -> b) -> a -> b
$ \(WithFingerprint Map (HeaderHash blk) (InvalidBlockInfo blk)
invalid Fingerprint
fp) ->
            Map (HeaderHash blk) (InvalidBlockInfo blk)
-> Fingerprint
-> WithFingerprint (Map (HeaderHash blk) (InvalidBlockInfo blk))
forall a. a -> Fingerprint -> WithFingerprint a
WithFingerprint (Map (HeaderHash blk) (InvalidBlockInfo blk)
-> Map (HeaderHash blk) (InvalidBlockInfo blk)
-> Map (HeaderHash blk) (InvalidBlockInfo blk)
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map (HeaderHash blk) (InvalidBlockInfo blk)
invalid Map (HeaderHash blk) (InvalidBlockInfo blk)
invalidBlocks) (Fingerprint -> Fingerprint
forall a. Enum a => a -> a
succ Fingerprint
fp)
          TraceValidationEvent blk -> m ()
trace (TraceValidationEvent blk -> m ())
-> TraceValidationEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$
            AnchoredFragment (Header blk)
-> [Header blk] -> TraceValidationEvent blk
forall blk.
AnchoredFragment (Header blk)
-> [Header blk] -> TraceValidationEvent blk
CandidateContainsFutureBlocksExceedingClockSkew
              -- Trace the original @suffix@, as it contains the headers
              -- from the future
              AnchoredFragment (Header blk)
suffix
              [Header blk]
invalidHeaders

        -- Truncate the original 'ChainDiff' to match the truncated
        -- 'AnchoredFragment'.
        Either
  (ChainDiff (Header blk))
  (ValidatedChainDiff (Header blk) (LedgerDB' blk))
-> m (Either
        (ChainDiff (Header blk))
        (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   (ChainDiff (Header blk))
   (ValidatedChainDiff (Header blk) (LedgerDB' blk))
 -> m (Either
         (ChainDiff (Header blk))
         (ValidatedChainDiff (Header blk) (LedgerDB' blk))))
-> Either
     (ChainDiff (Header blk))
     (ValidatedChainDiff (Header blk) (LedgerDB' blk))
-> m (Either
        (ChainDiff (Header blk))
        (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
forall a b. (a -> b) -> a -> b
$ ChainDiff (Header blk)
-> Either
     (ChainDiff (Header blk))
     (ValidatedChainDiff (Header blk) (LedgerDB' blk))
forall a b. a -> Either a b
Left (ChainDiff (Header blk)
 -> Either
      (ChainDiff (Header blk))
      (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
-> ChainDiff (Header blk)
-> Either
     (ChainDiff (Header blk))
     (ValidatedChainDiff (Header blk) (LedgerDB' blk))
forall a b. (a -> b) -> a -> b
$ Point (Header blk)
-> ChainDiff (Header blk) -> ChainDiff (Header blk)
forall b.
(HasHeader b, HasCallStack) =>
Point b -> ChainDiff b -> ChainDiff b
Diff.truncate (Point (Header blk) -> Point (Header blk)
forall b b'.
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (AnchoredFragment (Header blk) -> Point (Header blk)
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.headPoint AnchoredFragment (Header blk)
suffix')) ChainDiff (Header blk)
chainDiff
  where
    ChainSelEnv { TraceValidationEvent blk -> m ()
trace :: TraceValidationEvent blk -> m ()
trace :: forall (m :: * -> *) blk.
ChainSelEnv m blk -> TraceValidationEvent blk -> m ()
trace, StrictTVar
  m (WithFingerprint (Map (HeaderHash blk) (InvalidBlockInfo blk)))
varInvalid :: StrictTVar
  m (WithFingerprint (Map (HeaderHash blk) (InvalidBlockInfo blk)))
varInvalid :: forall (m :: * -> *) blk.
ChainSelEnv m blk
-> StrictTVar m (WithFingerprint (InvalidBlocks blk))
varInvalid, StrictTVar m (Map (HeaderHash blk) (Header blk))
varFutureBlocks :: StrictTVar m (Map (HeaderHash blk) (Header blk))
varFutureBlocks :: forall (m :: * -> *) blk.
ChainSelEnv m blk -> StrictTVar m (FutureBlocks blk)
varFutureBlocks, CheckInFuture m blk
futureCheck :: CheckInFuture m blk
futureCheck :: forall (m :: * -> *) blk. ChainSelEnv m blk -> CheckInFuture m blk
futureCheck } =
      ChainSelEnv m blk
chainSelEnv

    ValidatedChainDiff chainDiff :: ChainDiff (Header blk)
chainDiff@(ChainDiff Word64
_ AnchoredFragment (Header blk)
suffix) LedgerDB' blk
_ = ValidatedChainDiff (Header blk) (LedgerDB' blk)
validatedChainDiff

    validatedSuffix :: ValidatedFragment (Header blk) (LedgerState blk)
    validatedSuffix :: ValidatedFragment (Header blk) (LedgerState blk)
validatedSuffix =
      ExtLedgerState blk -> LedgerState blk
forall blk. ExtLedgerState blk -> LedgerState blk
ledgerState (ExtLedgerState blk -> LedgerState blk)
-> (LedgerDB' blk -> ExtLedgerState blk)
-> LedgerDB' blk
-> LedgerState blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerDB' blk -> ExtLedgerState blk
forall l r. LedgerDB l r -> l
LgrDB.ledgerDbCurrent (LedgerDB' blk -> LedgerState blk)
-> ValidatedFragment (Header blk) (LedgerDB' blk)
-> ValidatedFragment (Header blk) (LedgerState blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      ValidatedChainDiff (Header blk) (LedgerDB' blk)
-> ValidatedFragment (Header blk) (LedgerDB' blk)
forall l b.
(IsLedger l, HasHeader b, HeaderHash l ~ HeaderHash b,
 HasCallStack) =>
ValidatedChainDiff b l -> ValidatedFragment b l
ValidatedDiff.toValidatedFragment ValidatedChainDiff (Header blk) (LedgerDB' blk)
validatedChainDiff

-- | Validate a candidate chain using 'ledgerValidate' and 'futureCheck'.
validateCandidate
  :: ( IOLike m
     , LedgerSupportsProtocol blk
     , HasCallStack
     )
  => ChainSelEnv m blk
  -> ChainDiff (Header blk)
  -> m (ValidationResult blk)
validateCandidate :: ChainSelEnv m blk
-> ChainDiff (Header blk) -> m (ValidationResult blk)
validateCandidate ChainSelEnv m blk
chainSelEnv ChainDiff (Header blk)
chainDiff =
    ChainSelEnv m blk
-> ChainDiff (Header blk)
-> m (ValidatedChainDiff (Header blk) (LedgerDB' blk))
forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsProtocol blk, HasCallStack) =>
ChainSelEnv m blk
-> ChainDiff (Header blk)
-> m (ValidatedChainDiff (Header blk) (LedgerDB' blk))
ledgerValidateCandidate ChainSelEnv m blk
chainSelEnv ChainDiff (Header blk)
chainDiff m (ValidatedChainDiff (Header blk) (LedgerDB' blk))
-> (ValidatedChainDiff (Header blk) (LedgerDB' blk)
    -> m (ValidationResult blk))
-> m (ValidationResult blk)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      ValidatedChainDiff (Header blk) (LedgerDB' blk)
validatedChainDiff
        | ValidatedChainDiff (Header blk) (LedgerDB' blk) -> Bool
forall b l. HasHeader b => ValidatedChainDiff b l -> Bool
ValidatedDiff.rollbackExceedsSuffix ValidatedChainDiff (Header blk) (LedgerDB' blk)
validatedChainDiff
        -> ValidationResult blk -> m (ValidationResult blk)
forall (m :: * -> *) a. Monad m => a -> m a
return ValidationResult blk
forall blk. ValidationResult blk
InsufficientSuffix
        | Bool
otherwise
        -> ChainSelEnv m blk
-> ValidatedChainDiff (Header blk) (LedgerDB' blk)
-> m (Either
        (ChainDiff (Header blk))
        (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsProtocol blk) =>
ChainSelEnv m blk
-> ValidatedChainDiff (Header blk) (LedgerDB' blk)
-> m (Either
        (ChainDiff (Header blk))
        (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
futureCheckCandidate ChainSelEnv m blk
chainSelEnv ValidatedChainDiff (Header blk) (LedgerDB' blk)
validatedChainDiff m (Either
     (ChainDiff (Header blk))
     (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
-> (Either
      (ChainDiff (Header blk))
      (ValidatedChainDiff (Header blk) (LedgerDB' blk))
    -> m (ValidationResult blk))
-> m (ValidationResult blk)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Left ChainDiff (Header blk)
chainDiff'
              | ChainDiff (Header blk) -> Bool
forall b. HasHeader b => ChainDiff b -> Bool
Diff.rollbackExceedsSuffix ChainDiff (Header blk)
chainDiff'
              -> ValidationResult blk -> m (ValidationResult blk)
forall (m :: * -> *) a. Monad m => a -> m a
return ValidationResult blk
forall blk. ValidationResult blk
InsufficientSuffix
              | Bool
otherwise
              -> ValidationResult blk -> m (ValidationResult blk)
forall (m :: * -> *) a. Monad m => a -> m a
return (ValidationResult blk -> m (ValidationResult blk))
-> ValidationResult blk -> m (ValidationResult blk)
forall a b. (a -> b) -> a -> b
$ ChainDiff (Header blk) -> ValidationResult blk
forall blk. ChainDiff (Header blk) -> ValidationResult blk
ValidPrefix ChainDiff (Header blk)
chainDiff'
          Right ValidatedChainDiff (Header blk) (LedgerDB' blk)
validatedChainDiff'
              | ValidatedChainDiff (Header blk) (LedgerDB' blk) -> Bool
forall b l. HasHeader b => ValidatedChainDiff b l -> Bool
ValidatedDiff.rollbackExceedsSuffix ValidatedChainDiff (Header blk) (LedgerDB' blk)
validatedChainDiff'
              -> ValidationResult blk -> m (ValidationResult blk)
forall (m :: * -> *) a. Monad m => a -> m a
return ValidationResult blk
forall blk. ValidationResult blk
InsufficientSuffix
              | AnchoredFragment (Header blk) -> Int
forall block. HasHeader block => AnchoredFragment block -> Int
AF.length (ChainDiff (Header blk) -> AnchoredFragment (Header blk)
forall b. ChainDiff b -> AnchoredFragment b
Diff.getSuffix ChainDiff (Header blk)
chainDiff) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==
                AnchoredFragment (Header blk) -> Int
forall block. HasHeader block => AnchoredFragment block -> Int
AF.length (ChainDiff (Header blk) -> AnchoredFragment (Header blk)
forall b. ChainDiff b -> AnchoredFragment b
Diff.getSuffix ChainDiff (Header blk)
chainDiff')
                -- No truncation
              -> ValidationResult blk -> m (ValidationResult blk)
forall (m :: * -> *) a. Monad m => a -> m a
return (ValidationResult blk -> m (ValidationResult blk))
-> ValidationResult blk -> m (ValidationResult blk)
forall a b. (a -> b) -> a -> b
$ ValidatedChainDiff (Header blk) (LedgerDB' blk)
-> ValidationResult blk
forall blk.
ValidatedChainDiff (Header blk) (LedgerDB' blk)
-> ValidationResult blk
FullyValid ValidatedChainDiff (Header blk) (LedgerDB' blk)
validatedChainDiff'
              | Bool
otherwise
                -- In case of invalid blocks but no blocks from the future, we
                -- throw away the ledger corresponding to the truncated
                -- fragment and will have to validate it again, even when it's
                -- the sole candidate.
              -> ValidationResult blk -> m (ValidationResult blk)
forall (m :: * -> *) a. Monad m => a -> m a
return (ValidationResult blk -> m (ValidationResult blk))
-> ValidationResult blk -> m (ValidationResult blk)
forall a b. (a -> b) -> a -> b
$ ChainDiff (Header blk) -> ValidationResult blk
forall blk. ChainDiff (Header blk) -> ValidationResult blk
ValidPrefix ChainDiff (Header blk)
chainDiff'
            where
              chainDiff' :: ChainDiff (Header blk)
chainDiff' = ValidatedChainDiff (Header blk) (LedgerDB' blk)
-> ChainDiff (Header blk)
forall b l. ValidatedChainDiff b l -> ChainDiff b
ValidatedDiff.getChainDiff ValidatedChainDiff (Header blk) (LedgerDB' blk)
validatedChainDiff'

{-------------------------------------------------------------------------------
  'ChainAndLedger'
-------------------------------------------------------------------------------}

-- | Instantiate 'ValidatedFragment' in the way that chain selection requires.
type ChainAndLedger blk = ValidatedFragment (Header blk) (LedgerDB' blk)

{-------------------------------------------------------------------------------
  Helpers
-------------------------------------------------------------------------------}

-- | Wrap a @getter@ function so that it returns 'Nothing' for invalid blocks.
ignoreInvalid
  :: HasHeader blk
  => proxy blk
  -> InvalidBlocks blk
  -> (HeaderHash blk -> Maybe a)
  -> (HeaderHash blk -> Maybe a)
ignoreInvalid :: proxy blk
-> InvalidBlocks blk
-> (HeaderHash blk -> Maybe a)
-> HeaderHash blk
-> Maybe a
ignoreInvalid proxy blk
_ InvalidBlocks blk
invalid HeaderHash blk -> Maybe a
getter HeaderHash blk
hash
    | HeaderHash blk -> InvalidBlocks blk -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member HeaderHash blk
hash InvalidBlocks blk
invalid = Maybe a
forall a. Maybe a
Nothing
    | Bool
otherwise               = HeaderHash blk -> Maybe a
getter HeaderHash blk
hash

-- | Wrap a @successors@ function so that invalid blocks are not returned as
-- successors.
ignoreInvalidSuc
  :: HasHeader blk
  => proxy blk
  -> InvalidBlocks blk
  -> (ChainHash blk -> Set (HeaderHash blk))
  -> (ChainHash blk -> Set (HeaderHash blk))
ignoreInvalidSuc :: proxy blk
-> InvalidBlocks blk
-> (ChainHash blk -> Set (HeaderHash blk))
-> ChainHash blk
-> Set (HeaderHash blk)
ignoreInvalidSuc proxy blk
_ InvalidBlocks blk
invalid ChainHash blk -> Set (HeaderHash blk)
succsOf =
    (HeaderHash blk -> Bool)
-> Set (HeaderHash blk) -> Set (HeaderHash blk)
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (HeaderHash blk -> InvalidBlocks blk -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.notMember` InvalidBlocks blk
invalid) (Set (HeaderHash blk) -> Set (HeaderHash blk))
-> (ChainHash blk -> Set (HeaderHash blk))
-> ChainHash blk
-> Set (HeaderHash blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainHash blk -> Set (HeaderHash blk)
succsOf