{-# LANGUAGE BangPatterns             #-}
{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE LambdaCase               #-}
{-# LANGUAGE NamedFieldPuns           #-}
{-# LANGUAGE ScopedTypeVariables      #-}
{-# LANGUAGE StandaloneDeriving       #-}
module Ouroboros.Consensus.Storage.ChainDB.Impl.Paths (
    -- * LookupBlockInfo
    LookupBlockInfo
    -- * Candidates
  , extendWithSuccessors
  , maximalCandidates
    -- * Path
  , Path (..)
  , computePath
    -- * Reverse path
  , ReversePath (..)
  , computeReversePath
    -- * Reachability
  , isReachable
  ) where

import           Data.Foldable (foldl')
import           Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NE
import           Data.Maybe (fromMaybe, mapMaybe)
import           Data.Set (Set)
import qualified Data.Set as Set
import           Data.Word (Word64)

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

import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Fragment.Diff (ChainDiff (..))
import qualified Ouroboros.Consensus.Fragment.Diff as Diff

import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB

import           Ouroboros.Consensus.Storage.ChainDB.API hiding (ChainDB (..),
                     closeDB, getMaxSlotNo)

{-------------------------------------------------------------------------------
  LookupBlockInfo
-------------------------------------------------------------------------------}

-- | Return the block info for the block with the given hash. Return 'Nothing'
-- when not in the VolatileDB.
type LookupBlockInfo blk = HeaderHash blk -> Maybe (VolatileDB.BlockInfo blk)

{-------------------------------------------------------------------------------
  Candidates
-------------------------------------------------------------------------------}

-- | Compute the /maximal/ candidates starting at the specified point
--
-- As discussed in the Consensus Report, the set of /maximal/ candidates doesn't
-- include prefixes.
--
-- PRECONDITION: the block to which the given point corresponds is part of the
-- VolatileDB.
--
-- The first element in each list of hashes is the hash /after/ the specified
-- hash. Thus, when building fragments from these lists of hashes, they
-- fragments must be /anchored/ at the specified hash, but not contain it.
--
-- NOTE: it is possible that no candidates are found, but don't forget that
-- the chain (fragment) ending with @B@ is also a potential candidate.
maximalCandidates ::
     forall blk.
     (ChainHash blk -> Set (HeaderHash blk))
     -- ^ @filterByPredecessor@
  -> Point blk -- ^ @B@
  -> [NonEmpty (HeaderHash blk)]
     -- ^ Each element in the list is a list of hashes from which we can
     -- construct a fragment anchored at the point @B@.
maximalCandidates :: (ChainHash blk -> Set (HeaderHash blk))
-> Point blk -> [NonEmpty (HeaderHash blk)]
maximalCandidates ChainHash blk -> Set (HeaderHash blk)
succsOf Point blk
b = ([HeaderHash blk] -> Maybe (NonEmpty (HeaderHash blk)))
-> [[HeaderHash blk]] -> [NonEmpty (HeaderHash blk)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe [HeaderHash blk] -> Maybe (NonEmpty (HeaderHash blk))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty ([[HeaderHash blk]] -> [NonEmpty (HeaderHash blk)])
-> [[HeaderHash blk]] -> [NonEmpty (HeaderHash blk)]
forall a b. (a -> b) -> a -> b
$ ChainHash blk -> [[HeaderHash blk]]
go (Point blk -> ChainHash blk
forall block. Point block -> ChainHash block
pointHash Point blk
b)
  where
    go :: ChainHash blk -> [[HeaderHash blk]]
    go :: ChainHash blk -> [[HeaderHash blk]]
go ChainHash blk
mbHash = case Set (HeaderHash blk) -> [HeaderHash blk]
forall a. Set a -> [a]
Set.toList (Set (HeaderHash blk) -> [HeaderHash blk])
-> Set (HeaderHash blk) -> [HeaderHash blk]
forall a b. (a -> b) -> a -> b
$ ChainHash blk -> Set (HeaderHash blk)
succsOf ChainHash blk
mbHash of
      []    -> [[]]
      [HeaderHash blk]
succs -> [ HeaderHash blk
next HeaderHash blk -> [HeaderHash blk] -> [HeaderHash blk]
forall a. a -> [a] -> [a]
: [HeaderHash blk]
candidate
               | HeaderHash blk
next <- [HeaderHash blk]
succs
               , [HeaderHash blk]
candidate <- ChainHash blk -> [[HeaderHash blk]]
go (HeaderHash blk -> ChainHash blk
forall b. HeaderHash b -> ChainHash b
BlockHash HeaderHash blk
next)
               ]

-- | Extend the 'ChainDiff' with the successors found by 'maximalCandidates'.
--
-- In case no successors were found, the original 'ChainDiff' is returned as a
-- singleton.
--
-- In case successors /were/ found, the original 'ChainDiff' is /not/
-- included, only its extensions.
--
-- Only the longest possible extensions are returned, no intermediary prefixes
-- of extensions.
extendWithSuccessors ::
     forall blk. HasHeader blk
  => (ChainHash blk -> Set (HeaderHash blk))
  -> LookupBlockInfo blk
  -> ChainDiff (HeaderFields blk)
  -> NonEmpty (ChainDiff (HeaderFields blk))
extendWithSuccessors :: (ChainHash blk -> Set (HeaderHash blk))
-> LookupBlockInfo blk
-> ChainDiff (HeaderFields blk)
-> NonEmpty (ChainDiff (HeaderFields blk))
extendWithSuccessors ChainHash blk -> Set (HeaderHash blk)
succsOf LookupBlockInfo blk
lookupBlockInfo ChainDiff (HeaderFields blk)
diff =
    case [ChainDiff (HeaderFields blk)]
-> Maybe (NonEmpty (ChainDiff (HeaderFields blk)))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [ChainDiff (HeaderFields blk)]
extensions of
      Maybe (NonEmpty (ChainDiff (HeaderFields blk)))
Nothing          -> ChainDiff (HeaderFields blk)
diff ChainDiff (HeaderFields blk)
-> [ChainDiff (HeaderFields blk)]
-> NonEmpty (ChainDiff (HeaderFields blk))
forall a. a -> [a] -> NonEmpty a
NE.:| []
      Just NonEmpty (ChainDiff (HeaderFields blk))
extensions' -> NonEmpty (ChainDiff (HeaderFields blk))
extensions'
  where
    extensions :: [ChainDiff (HeaderFields blk)]
extensions =
        [ (ChainDiff (HeaderFields blk)
 -> HeaderFields blk -> ChainDiff (HeaderFields blk))
-> ChainDiff (HeaderFields blk)
-> NonEmpty (HeaderFields blk)
-> ChainDiff (HeaderFields blk)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ChainDiff (HeaderFields blk)
-> HeaderFields blk -> ChainDiff (HeaderFields blk)
forall b. HasHeader b => ChainDiff b -> b -> ChainDiff b
Diff.append ChainDiff (HeaderFields blk)
diff (HeaderHash blk -> HeaderFields blk
lookupHeaderFields (HeaderHash blk -> HeaderFields blk)
-> NonEmpty (HeaderHash blk) -> NonEmpty (HeaderFields blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (HeaderHash blk)
candHashes)
        | NonEmpty (HeaderHash blk)
candHashes <- (ChainHash blk -> Set (HeaderHash blk))
-> Point blk -> [NonEmpty (HeaderHash blk)]
forall blk.
(ChainHash blk -> Set (HeaderHash blk))
-> Point blk -> [NonEmpty (HeaderHash blk)]
maximalCandidates ChainHash blk -> Set (HeaderHash blk)
succsOf (Point (HeaderFields blk) -> Point blk
forall b b'.
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (ChainDiff (HeaderFields blk) -> Point (HeaderFields blk)
forall b. HasHeader b => ChainDiff b -> Point b
Diff.getTip ChainDiff (HeaderFields blk)
diff))
        ]

    lookupHeaderFields :: HeaderHash blk -> HeaderFields blk
    lookupHeaderFields :: HeaderHash blk -> HeaderFields blk
lookupHeaderFields =
          BlockInfo blk -> HeaderFields blk
forall blk. BlockInfo blk -> HeaderFields blk
headerFieldsFromBlockInfo
          -- The successor mapping is populated with the blocks in the
          -- VolatileDB, so looking up the block info of a successor /must/
          -- succeed.
        (BlockInfo blk -> HeaderFields blk)
-> (HeaderHash blk -> BlockInfo blk)
-> HeaderHash blk
-> HeaderFields blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockInfo blk -> Maybe (BlockInfo blk) -> BlockInfo blk
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> BlockInfo blk
forall a. HasCallStack => [Char] -> a
error [Char]
"successor must in the VolatileDB")
        (Maybe (BlockInfo blk) -> BlockInfo blk)
-> LookupBlockInfo blk -> HeaderHash blk -> BlockInfo blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LookupBlockInfo blk
lookupBlockInfo

{-------------------------------------------------------------------------------
  Paths
-------------------------------------------------------------------------------}

-- | Construct a path backwards through the VolatileDB.
--
-- We walk backwards through the VolatileDB, constructing a 'Path' from the
-- 'StreamTo' to the 'StreamFrom'.
--
-- If the range is invalid, 'Nothing' is returned.
--
-- See the documentation of 'Path'.
computePath ::
     forall blk. HasHeader blk
  => LookupBlockInfo blk
  -> StreamFrom blk
  -> StreamTo   blk
  -> Maybe (Path blk)
computePath :: LookupBlockInfo blk
-> StreamFrom blk -> StreamTo blk -> Maybe (Path blk)
computePath LookupBlockInfo blk
lookupBlockInfo StreamFrom blk
from StreamTo blk
to =
    case LookupBlockInfo blk -> HeaderHash blk -> Maybe (ReversePath blk)
forall blk.
LookupBlockInfo blk -> HeaderHash blk -> Maybe (ReversePath blk)
computeReversePath LookupBlockInfo blk
lookupBlockInfo (RealPoint blk -> HeaderHash blk
forall blk. RealPoint blk -> HeaderHash blk
realPointHash RealPoint blk
endPt) of
      Maybe (ReversePath blk)
Nothing      -> Path blk -> Maybe (Path blk)
forall a. a -> Maybe a
Just (Path blk -> Maybe (Path blk)) -> Path blk -> Maybe (Path blk)
forall a b. (a -> b) -> a -> b
$ RealPoint blk -> Path blk
forall blk. RealPoint blk -> Path blk
NotInVolatileDB RealPoint blk
endPt
      Just ReversePath blk
volPath -> [RealPoint blk] -> ReversePath blk -> Maybe (Path blk)
go [] ReversePath blk
volPath
  where
    endPt :: RealPoint blk
    endPt :: RealPoint blk
endPt = case StreamTo blk
to of
        StreamToInclusive RealPoint blk
pt -> RealPoint blk
pt

    fieldsToRealPoint :: HeaderFields blk -> RealPoint blk
    fieldsToRealPoint :: HeaderFields blk -> RealPoint blk
fieldsToRealPoint HeaderFields blk
flds =
        SlotNo -> HeaderHash blk -> RealPoint blk
forall blk. SlotNo -> HeaderHash blk -> RealPoint blk
RealPoint (HeaderFields blk -> SlotNo
forall b. HeaderFields b -> SlotNo
headerFieldSlot HeaderFields blk
flds) (HeaderFields blk -> HeaderHash blk
forall b. HeaderFields b -> HeaderHash b
headerFieldHash HeaderFields blk
flds)

    -- | Convert the 'HeaderFields' to a 'RealPoint' and prepend that to the
    -- accumulator.
    --
    -- NOTE: we will store the returned list in the state of a ChainDB
    -- iterator as a lazy non-empty list. To avoid thunks, we force the
    -- elements now, when adding them to the accumulator. TODO #2341
    addToAcc :: HeaderFields blk -> [RealPoint blk] -> [RealPoint blk]
    addToAcc :: HeaderFields blk -> [RealPoint blk] -> [RealPoint blk]
addToAcc HeaderFields blk
flds [RealPoint blk]
pts = RealPoint blk
pt RealPoint blk -> [RealPoint blk] -> [RealPoint blk]
forall a. a -> [a] -> [a]
: [RealPoint blk]
pts
        -- When the returned list is forced, @pt@ is forced. The returned list
        -- is forced because the accumulator is forced in @go@.
      where
        !pt :: RealPoint blk
pt = HeaderFields blk -> RealPoint blk
fieldsToRealPoint HeaderFields blk
flds

    go ::
         [RealPoint blk]  -- ^ Accumulator for the 'Path'
      -> ReversePath blk  -- ^ Prefix of the path to 'StreamFrom'
      -> Maybe (Path blk)
    go :: [RealPoint blk] -> ReversePath blk -> Maybe (Path blk)
go ![RealPoint blk]
acc = \case
        ReversePath blk
StoppedAtGenesis
          | StreamFromExclusive Point blk
GenesisPoint <- StreamFrom blk
from
          -> Path blk -> Maybe (Path blk)
forall a. a -> Maybe a
Just (Path blk -> Maybe (Path blk)) -> Path blk -> Maybe (Path blk)
forall a b. (a -> b) -> a -> b
$ [RealPoint blk] -> Path blk
forall blk. [RealPoint blk] -> Path blk
CompletelyInVolatileDB [RealPoint blk]
acc
          | Bool
otherwise
            -- If 'StreamFrom' was not from genesis, then the range must be
            -- invalid.
          -> Maybe (Path blk)
forall a. Maybe a
Nothing

        StoppedAt HeaderHash blk
hash BlockNo
_bno
          | StreamFromExclusive Point blk
GenesisPoint <- StreamFrom blk
from
          -> Path blk -> Maybe (Path blk)
forall a. a -> Maybe a
Just (Path blk -> Maybe (Path blk)) -> Path blk -> Maybe (Path blk)
forall a b. (a -> b) -> a -> b
$ HeaderHash blk -> [RealPoint blk] -> Path blk
forall blk. HeaderHash blk -> [RealPoint blk] -> Path blk
PartiallyInVolatileDB HeaderHash blk
hash [RealPoint blk]
acc
          | StreamFromExclusive (BlockPoint SlotNo
_ HeaderHash blk
hash') <- StreamFrom blk
from
          , HeaderHash blk
hash HeaderHash blk -> HeaderHash blk -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderHash blk
hash'
          -> Path blk -> Maybe (Path blk)
forall a. a -> Maybe a
Just (Path blk -> Maybe (Path blk)) -> Path blk -> Maybe (Path blk)
forall a b. (a -> b) -> a -> b
$ [RealPoint blk] -> Path blk
forall blk. [RealPoint blk] -> Path blk
CompletelyInVolatileDB [RealPoint blk]
acc
          | StreamFromExclusive (BlockPoint SlotNo
_ HeaderHash blk
_) <- StreamFrom blk
from
          -> Path blk -> Maybe (Path blk)
forall a. a -> Maybe a
Just (Path blk -> Maybe (Path blk)) -> Path blk -> Maybe (Path blk)
forall a b. (a -> b) -> a -> b
$ HeaderHash blk -> [RealPoint blk] -> Path blk
forall blk. HeaderHash blk -> [RealPoint blk] -> Path blk
PartiallyInVolatileDB HeaderHash blk
hash [RealPoint blk]
acc
          | StreamFromInclusive RealPoint blk
_ <- StreamFrom blk
from
          -> Path blk -> Maybe (Path blk)
forall a. a -> Maybe a
Just (Path blk -> Maybe (Path blk)) -> Path blk -> Maybe (Path blk)
forall a b. (a -> b) -> a -> b
$ HeaderHash blk -> [RealPoint blk] -> Path blk
forall blk. HeaderHash blk -> [RealPoint blk] -> Path blk
PartiallyInVolatileDB HeaderHash blk
hash [RealPoint blk]
acc

        ReversePath blk
volPath' ::> (HeaderFields blk
flds, IsEBB
_isEBB)
          | StreamFromExclusive Point blk
GenesisPoint <- StreamFrom blk
from
          -> [RealPoint blk] -> ReversePath blk -> Maybe (Path blk)
go (HeaderFields blk -> [RealPoint blk] -> [RealPoint blk]
addToAcc HeaderFields blk
flds [RealPoint blk]
acc) ReversePath blk
volPath'
          | StreamFromExclusive (BlockPoint SlotNo
_ HeaderHash blk
hash') <- StreamFrom blk
from
          , HeaderFields blk -> HeaderHash blk
forall b. HeaderFields b -> HeaderHash b
headerFieldHash HeaderFields blk
flds HeaderHash blk -> HeaderHash blk -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderHash blk
hash'
          -> Path blk -> Maybe (Path blk)
forall a. a -> Maybe a
Just (Path blk -> Maybe (Path blk)) -> Path blk -> Maybe (Path blk)
forall a b. (a -> b) -> a -> b
$ [RealPoint blk] -> Path blk
forall blk. [RealPoint blk] -> Path blk
CompletelyInVolatileDB [RealPoint blk]
acc
          | StreamFromExclusive (BlockPoint SlotNo
_ HeaderHash blk
_) <- StreamFrom blk
from
          -> [RealPoint blk] -> ReversePath blk -> Maybe (Path blk)
go (HeaderFields blk -> [RealPoint blk] -> [RealPoint blk]
addToAcc HeaderFields blk
flds [RealPoint blk]
acc) ReversePath blk
volPath'
          | StreamFromInclusive RealPoint blk
pt' <- StreamFrom blk
from
          , HeaderFields blk -> RealPoint blk
fieldsToRealPoint HeaderFields blk
flds RealPoint blk -> RealPoint blk -> Bool
forall a. Eq a => a -> a -> Bool
== RealPoint blk
pt'
          -> Path blk -> Maybe (Path blk)
forall a. a -> Maybe a
Just (Path blk -> Maybe (Path blk)) -> Path blk -> Maybe (Path blk)
forall a b. (a -> b) -> a -> b
$ [RealPoint blk] -> Path blk
forall blk. [RealPoint blk] -> Path blk
CompletelyInVolatileDB (HeaderFields blk -> [RealPoint blk] -> [RealPoint blk]
addToAcc HeaderFields blk
flds [RealPoint blk]
acc)
          | StreamFromInclusive RealPoint blk
_ <- StreamFrom blk
from
          -> [RealPoint blk] -> ReversePath blk -> Maybe (Path blk)
go (HeaderFields blk -> [RealPoint blk] -> [RealPoint blk]
addToAcc HeaderFields blk
flds [RealPoint blk]
acc) ReversePath blk
volPath'

-- | A path through the VolatileDB from a 'StreamFrom' to a 'StreamTo'.
--
-- Invariant: the @AnchoredFragment@ (oldest first) constructed using the blocks
-- corresponding to the points in the path will be valid, i.e., the blocks
-- will fit onto each other.
data Path blk =
    NotInVolatileDB (RealPoint blk)
    -- ^ The @end@ point (@'StreamToInclusive' end@) was not part of the
    -- VolatileDB.
  | CompletelyInVolatileDB [RealPoint blk]
    -- ^ A complete path, from start point to end point was constructed from
    -- the VolatileDB. The list contains the points from oldest to newest.
    --
    -- * If the lower bound was @'StreamFromInclusive' pt@, then @pt@ will be
    --   the first element of the list.
    -- * If the lower bound was @'StreamFromExclusive' pt@, then the first
    --   element of the list will correspond to the first block after @pt@.
    --
    -- * If the upper bound was @'StreamToInclusive' pt@, then @pt@ will be
    --   the last element of the list.
  | PartiallyInVolatileDB (HeaderHash blk) [RealPoint blk]
    -- ^ Only a partial path could be constructed from the VolatileDB. The
    -- missing predecessor could still be in the ImmutableDB. The list
    -- contains the points from oldest to newest.
    --
    -- * The first element in the list is the point for which no predecessor
    --   is available in the VolatileDB. The block corresponding to the point
    --   itself, /is/ available in the VolatileDB.
    -- * The first argument is the hash of predecessor, the block that is not
    --   available in the VolatileDB.
    --
    -- Note: if the lower bound is exclusive, the block corresponding to it
    -- doesn't have to be part of the VolatileDB, it will result in a
    -- 'StartToEnd'.
    --
    -- The same invariants hold for the upper bound as for 'StartToEnd'.

deriving instance HasHeader blk => Eq   (Path blk)
deriving instance HasHeader blk => Show (Path blk)

{-------------------------------------------------------------------------------
  Reverse path
-------------------------------------------------------------------------------}

headerFieldsFromBlockInfo :: VolatileDB.BlockInfo blk -> HeaderFields blk
headerFieldsFromBlockInfo :: BlockInfo blk -> HeaderFields blk
headerFieldsFromBlockInfo VolatileDB.BlockInfo { SlotNo
biSlotNo :: forall blk. BlockInfo blk -> SlotNo
biSlotNo :: SlotNo
biSlotNo, HeaderHash blk
biHash :: forall blk. BlockInfo blk -> HeaderHash blk
biHash :: HeaderHash blk
biHash, BlockNo
biBlockNo :: forall blk. BlockInfo blk -> BlockNo
biBlockNo :: BlockNo
biBlockNo } =
    HeaderFields :: forall b. SlotNo -> BlockNo -> HeaderHash b -> HeaderFields b
HeaderFields {
        headerFieldHash :: HeaderHash blk
headerFieldHash    = HeaderHash blk
biHash
      , headerFieldSlot :: SlotNo
headerFieldSlot    = SlotNo
biSlotNo
      , headerFieldBlockNo :: BlockNo
headerFieldBlockNo = BlockNo
biBlockNo
      }

-- | A reverse path through the VolatileDB starting at a block in the
-- VolatileDB until we reach genesis or leave the VolatileDB.
data ReversePath blk =
      -- | The path stopped at genesis
      StoppedAtGenesis

      -- | The path stopped at this hash, which is the hash of the predecessor
      -- of the last block in the path (that was still stored in the
      -- VolatileDB).
      --
      -- The block corresponding to the predecessor is /not/ stored in the
      -- VolatileDB. Either because it is missing, or because it is old and
      -- has been garbage collected.
      --
      -- Since block numbers are consecutive, we subtract 1 from the block
      -- number of the last block to obtain the block number corresponding to
      -- this hash.
      --
      -- EBBs share their block number with their predecessor:
      --
      -- > block:         regular block 1 | EBB | regular block 2
      -- > block number:                X |   X | X + 1
      --
      -- So when the hash refers to regular block 1, we see that the successor
      -- block is an EBB and use its block number without subtracting 1.
      --
      -- Edge case: if there are two or more consecutive EBBs, we might
      -- predict the wrong block number, but there are no consecutive EBBs in
      -- practice, they are one epoch apart.
    | StoppedAt (HeaderHash blk) BlockNo

      -- | Snoc: the block with the given 'HeaderFields' is in the VolatileDB.
      -- We also track whether it is an EBB or not.
      --
      -- NOTE: we are intentionally lazy in the spine, as constructing the
      -- path requires lookups in the VolatileDB's in-memory indices, which
      -- are logarithmic in the size of the index.
    | (ReversePath blk) ::> (HeaderFields blk, IsEBB)

-- | Lazily compute the 'ReversePath' that starts (i.e., ends) with the given
-- 'HeaderHash'.
computeReversePath
  :: forall blk.
     LookupBlockInfo blk
  -> HeaderHash blk
     -- ^ End hash
  -> Maybe (ReversePath blk)
     -- ^ Reverse path from the end point to genesis or the first predecessor
     -- not in the VolatileDB. Nothing when the end hash is not in the
     -- VolatileDB.
computeReversePath :: LookupBlockInfo blk -> HeaderHash blk -> Maybe (ReversePath blk)
computeReversePath LookupBlockInfo blk
lookupBlockInfo HeaderHash blk
endHash =
    case LookupBlockInfo blk
lookupBlockInfo HeaderHash blk
endHash of
      Maybe (BlockInfo blk)
Nothing                                               -> Maybe (ReversePath blk)
forall a. Maybe a
Nothing
      Just blockInfo :: BlockInfo blk
blockInfo@VolatileDB.BlockInfo { BlockNo
biBlockNo :: BlockNo
biBlockNo :: forall blk. BlockInfo blk -> BlockNo
biBlockNo, IsEBB
biIsEBB :: forall blk. BlockInfo blk -> IsEBB
biIsEBB :: IsEBB
biIsEBB, ChainHash blk
biPrevHash :: forall blk. BlockInfo blk -> ChainHash blk
biPrevHash :: ChainHash blk
biPrevHash } -> ReversePath blk -> Maybe (ReversePath blk)
forall a. a -> Maybe a
Just (ReversePath blk -> Maybe (ReversePath blk))
-> ReversePath blk -> Maybe (ReversePath blk)
forall a b. (a -> b) -> a -> b
$
        ChainHash blk -> BlockNo -> IsEBB -> ReversePath blk
go ChainHash blk
biPrevHash BlockNo
biBlockNo IsEBB
biIsEBB ReversePath blk -> (HeaderFields blk, IsEBB) -> ReversePath blk
forall blk.
ReversePath blk -> (HeaderFields blk, IsEBB) -> ReversePath blk
::> (BlockInfo blk -> HeaderFields blk
forall blk. BlockInfo blk -> HeaderFields blk
headerFieldsFromBlockInfo BlockInfo blk
blockInfo, IsEBB
biIsEBB)
  where
    go ::
         ChainHash blk
         -- ^ The predecessor of the last block added to the path. Not
         -- necessarily in the VolatileDB.
      -> BlockNo  -- ^ The block number of the last block
      -> IsEBB    -- ^ Whether the last block is an EBB or not
      -> ReversePath blk
    go :: ChainHash blk -> BlockNo -> IsEBB -> ReversePath blk
go ChainHash blk
predecessor BlockNo
lastBlockNo IsEBB
lastIsEBB = case ChainHash blk
predecessor of
      ChainHash blk
GenesisHash        -> ReversePath blk
forall blk. ReversePath blk
StoppedAtGenesis
      BlockHash HeaderHash blk
prevHash -> case LookupBlockInfo blk
lookupBlockInfo HeaderHash blk
prevHash of
        Maybe (BlockInfo blk)
Nothing ->
          HeaderHash blk -> BlockNo -> ReversePath blk
forall blk. HeaderHash blk -> BlockNo -> ReversePath blk
StoppedAt HeaderHash blk
prevHash (BlockNo -> IsEBB -> BlockNo
prevBlockNo BlockNo
lastBlockNo IsEBB
lastIsEBB)
        Just blockInfo :: BlockInfo blk
blockInfo@VolatileDB.BlockInfo { BlockNo
biBlockNo :: BlockNo
biBlockNo :: forall blk. BlockInfo blk -> BlockNo
biBlockNo, IsEBB
biIsEBB :: IsEBB
biIsEBB :: forall blk. BlockInfo blk -> IsEBB
biIsEBB, ChainHash blk
biPrevHash :: ChainHash blk
biPrevHash :: forall blk. BlockInfo blk -> ChainHash blk
biPrevHash } ->
          ChainHash blk -> BlockNo -> IsEBB -> ReversePath blk
go ChainHash blk
biPrevHash BlockNo
biBlockNo IsEBB
biIsEBB ReversePath blk -> (HeaderFields blk, IsEBB) -> ReversePath blk
forall blk.
ReversePath blk -> (HeaderFields blk, IsEBB) -> ReversePath blk
::> (BlockInfo blk -> HeaderFields blk
forall blk. BlockInfo blk -> HeaderFields blk
headerFieldsFromBlockInfo BlockInfo blk
blockInfo, IsEBB
biIsEBB)

    -- | Predict the block number of the missing predecessor.
    --
    -- PRECONDITION: the block number and 'IsEBB' correspond to a block that
    -- has a predecessor.
    --
    -- For regular blocks, this is just block number - 1, EBBs are special of
    -- course: they share their block number with their predecessor:
    --
    -- > block:         regular block 1 | EBB | regular block 2
    -- > block number:                X |   X | X + 1
    --
    -- Edge case: if there are two or more consecutive EBBs, we might predict
    -- the wrong block number, but there are no consecutive EBBs in practice
    -- (nor in the tests), they are one epoch apart.
    prevBlockNo :: BlockNo -> IsEBB -> BlockNo
    prevBlockNo :: BlockNo -> IsEBB -> BlockNo
prevBlockNo BlockNo
bno IsEBB
isEBB = case (BlockNo
bno, IsEBB
isEBB) of
      (BlockNo
0, IsEBB
IsNotEBB) -> [Char] -> BlockNo
forall a. HasCallStack => [Char] -> a
error [Char]
"precondition violated"
      (BlockNo
_, IsEBB
IsNotEBB) -> BlockNo
bno BlockNo -> BlockNo -> BlockNo
forall a. Num a => a -> a -> a
- BlockNo
1
      (BlockNo
_, IsEBB
IsEBB)    -> BlockNo
bno

{-------------------------------------------------------------------------------
  Reachability
-------------------------------------------------------------------------------}

-- | Try to connect the point @P@ to the chain fragment by chasing the
-- predecessors.
--
-- When successful, return a 'ChainDiff': the number of blocks to roll back
-- the chain fragment to the intersection point and a fragment anchored at the
-- intersection point containing the 'HeaderFields' corresponding to the
-- blocks needed to connect to @P@. The intersection point will be the most
-- recent intersection point.
--
-- Returns 'Nothing' when @P@ is not in the VolatileDB or when @P@ is not
-- connected to the given chain fragment.
--
-- POSTCONDITION: the returned number of blocks to roll back is less than or
-- equal to the length of the given chain fragment.
--
-- Note that the number of returned points can be smaller than the number of
-- blocks to roll back. This means @P@ is on a fork shorter than the given
-- chain fragment.
--
-- A 'ChainDiff' is returned iff @P@ is on the chain fragment. Moreover, when
-- the number of blocks to roll back is also 0, it must be that @P@ is the tip
-- of the chain fragment.
--
-- When the suffix of the 'ChainDiff' is non-empty, @P@ will be the last point
-- in the suffix.
isReachable
  :: forall blk. (HasHeader blk, GetHeader blk)
  => LookupBlockInfo blk
  -> AnchoredFragment (Header blk) -- ^ Chain fragment to connect the point to
  -> RealPoint blk
  -> Maybe (ChainDiff (HeaderFields blk))
isReachable :: LookupBlockInfo blk
-> AnchoredFragment (Header blk)
-> RealPoint blk
-> Maybe (ChainDiff (HeaderFields blk))
isReachable LookupBlockInfo blk
lookupBlockInfo = \AnchoredFragment (Header blk)
chain RealPoint blk
b ->
    case LookupBlockInfo blk -> HeaderHash blk -> Maybe (ReversePath blk)
forall blk.
LookupBlockInfo blk -> HeaderHash blk -> Maybe (ReversePath blk)
computeReversePath LookupBlockInfo blk
lookupBlockInfo (RealPoint blk -> HeaderHash blk
forall blk. RealPoint blk -> HeaderHash blk
realPointHash RealPoint blk
b) of
      -- Block not in the VolatileDB, so it's unreachable
      Maybe (ReversePath blk)
Nothing          -> Maybe (ChainDiff (HeaderFields blk))
forall a. Maybe a
Nothing
      Just ReversePath blk
reversePath -> AnchoredFragment (Header blk)
-> ReversePath blk
-> Word64
-> [HeaderFields blk]
-> Maybe (ChainDiff (HeaderFields blk))
go AnchoredFragment (Header blk)
chain ReversePath blk
reversePath Word64
0 []
  where
    -- | NOTE: the 'ReversePath' is lazy in its spine. We will only force as
    -- many elements as 'RealPoint's we return. In the worst case, the path is
    -- not connected to the current chain at all, in which case we do force
    -- the entire path.
    --
    -- We're trying to find a common block, i.e., one with the same point and
    -- thus the same slot. Both the chain and the path are ordered by slots,
    -- so we compare the slots and drop the largest one until we have a match
    -- in slot, then we check hashes. If those don't match, we drop both.
    -- Note: EBBs complicate things, see 'ebbAwareCompare'.
    go
      :: AnchoredFragment (Header blk)
         -- ^ Prefix of the current chain
      -> ReversePath blk
         -- ^ Prefix of the path through the VolatileDB
      -> Word64
         -- ^ Number of blocks we have had to roll back from the current chain
      -> [HeaderFields blk]
         -- ^ Accumulator for the suffix, from oldest to newest
      -> Maybe (ChainDiff (HeaderFields blk))
    go :: AnchoredFragment (Header blk)
-> ReversePath blk
-> Word64
-> [HeaderFields blk]
-> Maybe (ChainDiff (HeaderFields blk))
go AnchoredFragment (Header blk)
chain ReversePath blk
path !Word64
rollback [HeaderFields blk]
acc = case (AnchoredFragment (Header blk)
chain, ReversePath blk
path) of
        (AF.Empty Anchor (Header blk)
anchor, StoppedAt HeaderHash blk
hash BlockNo
bno)
          | Anchor (Header blk) -> WithOrigin BlockNo
forall block. Anchor block -> WithOrigin BlockNo
AF.anchorToBlockNo Anchor (Header blk)
anchor WithOrigin BlockNo -> WithOrigin BlockNo -> Bool
forall a. Eq a => a -> a -> Bool
== BlockNo -> WithOrigin BlockNo
forall t. t -> WithOrigin t
NotOrigin BlockNo
bno
          , Anchor (Header blk) -> ChainHash (Header blk)
forall block. Anchor block -> ChainHash block
AF.anchorToHash Anchor (Header blk)
anchor ChainHash (Header blk) -> ChainHash (Header blk) -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderHash (Header blk) -> ChainHash (Header blk)
forall b. HeaderHash b -> ChainHash b
BlockHash HeaderHash blk
HeaderHash (Header blk)
hash
          -> ChainDiff (HeaderFields blk)
-> Maybe (ChainDiff (HeaderFields blk))
forall a. a -> Maybe a
Just (Word64
-> AnchoredFragment (HeaderFields blk)
-> ChainDiff (HeaderFields blk)
forall b. Word64 -> AnchoredFragment b -> ChainDiff b
ChainDiff Word64
rollback (Anchor (HeaderFields blk)
-> [HeaderFields blk] -> AnchoredFragment (HeaderFields blk)
forall v a b. Anchorable v a b => a -> [b] -> AnchoredSeq v a b
AF.fromOldestFirst (Anchor (Header blk) -> Anchor (HeaderFields blk)
forall a b. (HeaderHash a ~ HeaderHash b) => Anchor a -> Anchor b
AF.castAnchor Anchor (Header blk)
anchor) [HeaderFields blk]
acc))
          | Bool
otherwise
          -> Maybe (ChainDiff (HeaderFields blk))
forall a. Maybe a
Nothing

        (AF.Empty Anchor (Header blk)
anchor, ReversePath blk
path' ::> (HeaderFields blk
flds, IsEBB
_))
          | Anchor blk -> WithOrigin (HeaderFields blk)
forall block. Anchor block -> WithOrigin (HeaderFields block)
AF.anchorToHeaderFields (Anchor (Header blk) -> Anchor blk
forall a b. (HeaderHash a ~ HeaderHash b) => Anchor a -> Anchor b
AF.castAnchor Anchor (Header blk)
anchor) WithOrigin (HeaderFields blk)
-> WithOrigin (HeaderFields blk) -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderFields blk -> WithOrigin (HeaderFields blk)
forall t. t -> WithOrigin t
NotOrigin HeaderFields blk
flds
          -> ChainDiff (HeaderFields blk)
-> Maybe (ChainDiff (HeaderFields blk))
forall a. a -> Maybe a
Just (Word64
-> AnchoredFragment (HeaderFields blk)
-> ChainDiff (HeaderFields blk)
forall b. Word64 -> AnchoredFragment b -> ChainDiff b
ChainDiff Word64
rollback (Anchor (HeaderFields blk)
-> [HeaderFields blk] -> AnchoredFragment (HeaderFields blk)
forall v a b. Anchorable v a b => a -> [b] -> AnchoredSeq v a b
AF.fromOldestFirst (Anchor (Header blk) -> Anchor (HeaderFields blk)
forall a b. (HeaderHash a ~ HeaderHash b) => Anchor a -> Anchor b
AF.castAnchor Anchor (Header blk)
anchor) [HeaderFields blk]
acc))
          | Anchor (Header blk) -> WithOrigin BlockNo
forall block. Anchor block -> WithOrigin BlockNo
AF.anchorToBlockNo Anchor (Header blk)
anchor WithOrigin BlockNo -> WithOrigin BlockNo -> Bool
forall a. Ord a => a -> a -> Bool
> BlockNo -> WithOrigin BlockNo
forall t. t -> WithOrigin t
NotOrigin (HeaderFields blk -> BlockNo
forall b. HeaderFields b -> BlockNo
headerFieldBlockNo HeaderFields blk
flds)
          -> Maybe (ChainDiff (HeaderFields blk))
forall a. Maybe a
Nothing
          | Bool
otherwise
          -> AnchoredFragment (Header blk)
-> ReversePath blk
-> Word64
-> [HeaderFields blk]
-> Maybe (ChainDiff (HeaderFields blk))
go AnchoredFragment (Header blk)
chain ReversePath blk
path' Word64
rollback (HeaderFields blk
fldsHeaderFields blk -> [HeaderFields blk] -> [HeaderFields blk]
forall a. a -> [a] -> [a]
:[HeaderFields blk]
acc)

        (AnchoredFragment (Header blk)
chain' AF.:> Header blk
hdr, StoppedAt HeaderHash blk
hash BlockNo
bno)
          | Header blk -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo Header blk
hdr BlockNo -> BlockNo -> Bool
forall a. Eq a => a -> a -> Bool
== BlockNo
bno
          , Header blk -> HeaderHash blk
forall blk. HasHeader (Header blk) => Header blk -> HeaderHash blk
headerHash Header blk
hdr HeaderHash blk -> HeaderHash blk -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderHash blk
hash
          , let anchor :: Anchor (HeaderFields blk)
anchor = Anchor (Header blk) -> Anchor (HeaderFields blk)
forall a b. (HeaderHash a ~ HeaderHash b) => Anchor a -> Anchor b
AF.castAnchor (Header blk -> Anchor (Header blk)
forall block. HasHeader block => block -> Anchor block
AF.anchorFromBlock Header blk
hdr)
          -> ChainDiff (HeaderFields blk)
-> Maybe (ChainDiff (HeaderFields blk))
forall a. a -> Maybe a
Just (Word64
-> AnchoredFragment (HeaderFields blk)
-> ChainDiff (HeaderFields blk)
forall b. Word64 -> AnchoredFragment b -> ChainDiff b
ChainDiff Word64
rollback (Anchor (HeaderFields blk)
-> [HeaderFields blk] -> AnchoredFragment (HeaderFields blk)
forall v a b. Anchorable v a b => a -> [b] -> AnchoredSeq v a b
AF.fromOldestFirst Anchor (HeaderFields blk)
anchor [HeaderFields blk]
acc))
          | Header blk -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo Header blk
hdr BlockNo -> BlockNo -> Bool
forall a. Ord a => a -> a -> Bool
< BlockNo
bno
          -> Maybe (ChainDiff (HeaderFields blk))
forall a. Maybe a
Nothing
          | Bool
otherwise
          -> AnchoredFragment (Header blk)
-> ReversePath blk
-> Word64
-> [HeaderFields blk]
-> Maybe (ChainDiff (HeaderFields blk))
go AnchoredFragment (Header blk)
chain' ReversePath blk
path (Word64
rollback Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1) [HeaderFields blk]
acc

        (AnchoredFragment (Header blk)
_, ReversePath blk
StoppedAtGenesis)
          | Anchor (Header blk) -> Bool
forall block. Anchor block -> Bool
AF.anchorIsGenesis (AnchoredFragment (Header blk) -> Anchor (Header blk)
forall v a b. AnchoredSeq v a b -> a
AF.anchor AnchoredFragment (Header blk)
chain)
          -> let !rollback' :: Word64
rollback' = Word64
rollback Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (AnchoredFragment (Header blk) -> Int
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Int
AF.length AnchoredFragment (Header blk)
chain)
             in ChainDiff (HeaderFields blk)
-> Maybe (ChainDiff (HeaderFields blk))
forall a. a -> Maybe a
Just (Word64
-> AnchoredFragment (HeaderFields blk)
-> ChainDiff (HeaderFields blk)
forall b. Word64 -> AnchoredFragment b -> ChainDiff b
ChainDiff Word64
rollback' (Anchor (HeaderFields blk)
-> [HeaderFields blk] -> AnchoredFragment (HeaderFields blk)
forall v a b. Anchorable v a b => a -> [b] -> AnchoredSeq v a b
AF.fromOldestFirst Anchor (HeaderFields blk)
forall block. Anchor block
AF.AnchorGenesis [HeaderFields blk]
acc))
          | Bool
otherwise
          -> Maybe (ChainDiff (HeaderFields blk))
forall a. Maybe a
Nothing

        (AnchoredFragment (Header blk)
chain' AF.:> Header blk
hdr, ReversePath blk
path' ::> (HeaderFields blk
flds, IsEBB
ptIsEBB)) ->
          case Header blk
hdr Header blk -> (BlockNo, IsEBB) -> Ordering
`ebbAwareCompare` (HeaderFields blk -> BlockNo
forall b. HeaderFields b -> BlockNo
headerFieldBlockNo HeaderFields blk
flds, IsEBB
ptIsEBB) of
            -- Drop from the path
            Ordering
LT -> AnchoredFragment (Header blk)
-> ReversePath blk
-> Word64
-> [HeaderFields blk]
-> Maybe (ChainDiff (HeaderFields blk))
go AnchoredFragment (Header blk)
chain ReversePath blk
path' Word64
rollback (HeaderFields blk
fldsHeaderFields blk -> [HeaderFields blk] -> [HeaderFields blk]
forall a. a -> [a] -> [a]
:[HeaderFields blk]
acc)
            -- Drop from the current chain fragment
            Ordering
GT -> AnchoredFragment (Header blk)
-> ReversePath blk
-> Word64
-> [HeaderFields blk]
-> Maybe (ChainDiff (HeaderFields blk))
go AnchoredFragment (Header blk)
chain' ReversePath blk
path (Word64
rollback Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1) [HeaderFields blk]
acc
            -- Same slot and value for 'IsEBB'
            Ordering
EQ | Header blk -> HeaderHash (Header blk)
forall b. HasHeader b => b -> HeaderHash b
blockHash Header blk
hdr HeaderHash blk -> HeaderHash blk -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderFields blk -> HeaderHash blk
forall b. HeaderFields b -> HeaderHash b
headerFieldHash HeaderFields blk
flds
               , let anchor :: Anchor (HeaderFields blk)
anchor = Anchor (Header blk) -> Anchor (HeaderFields blk)
forall a b. (HeaderHash a ~ HeaderHash b) => Anchor a -> Anchor b
AF.castAnchor (Header blk -> Anchor (Header blk)
forall block. HasHeader block => block -> Anchor block
AF.anchorFromBlock Header blk
hdr)
               -- Found a match
               -> ChainDiff (HeaderFields blk)
-> Maybe (ChainDiff (HeaderFields blk))
forall a. a -> Maybe a
Just (Word64
-> AnchoredFragment (HeaderFields blk)
-> ChainDiff (HeaderFields blk)
forall b. Word64 -> AnchoredFragment b -> ChainDiff b
ChainDiff Word64
rollback (Anchor (HeaderFields blk)
-> [HeaderFields blk] -> AnchoredFragment (HeaderFields blk)
forall v a b. Anchorable v a b => a -> [b] -> AnchoredSeq v a b
AF.fromOldestFirst Anchor (HeaderFields blk)
anchor [HeaderFields blk]
acc))
               -- Different hashes, drop both
               | Bool
otherwise
               -> AnchoredFragment (Header blk)
-> ReversePath blk
-> Word64
-> [HeaderFields blk]
-> Maybe (ChainDiff (HeaderFields blk))
go AnchoredFragment (Header blk)
chain' ReversePath blk
path' (Word64
rollback Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1) (HeaderFields blk
fldsHeaderFields blk -> [HeaderFields blk] -> [HeaderFields blk]
forall a. a -> [a] -> [a]
:[HeaderFields blk]
acc)

    -- | EBBs have the same block number as their predecessor, which means
    -- that in case we have an EBB and a regular block with the same slot, the
    -- EBB comes /after/ the regular block.
    ebbAwareCompare :: Header blk -> (BlockNo, IsEBB) -> Ordering
    ebbAwareCompare :: Header blk -> (BlockNo, IsEBB) -> Ordering
ebbAwareCompare Header blk
hdr (BlockNo
ptBlockNo, IsEBB
ptIsEBB) =
      BlockNo -> BlockNo -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Header blk -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo Header blk
hdr) BlockNo
ptBlockNo Ordering -> Ordering -> Ordering
forall a. Monoid a => a -> a -> a
`mappend`
      case (Header blk -> IsEBB
forall blk. GetHeader blk => Header blk -> IsEBB
headerToIsEBB Header blk
hdr, IsEBB
ptIsEBB) of
        (IsEBB
IsEBB,    IsEBB
IsNotEBB) -> Ordering
GT
        (IsEBB
IsNotEBB, IsEBB
IsEBB)    -> Ordering
LT
        (IsEBB
IsEBB,    IsEBB
IsEBB)    -> Ordering
EQ
        (IsEBB
IsNotEBB, IsEBB
IsNotEBB) -> Ordering
EQ