{-# LANGUAGE CPP #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}

#if __GLASGOW_HASKELL__ >= 908
{-# OPTIONS_GHC -Wno-x-partial #-}
#endif

-- REVIEW: There is a `BlockTree` in `Test.Utils.TestBlock`. It relies on
-- different mechanisms but maybe we should rely on that instead to avoid
-- duplication.

module Test.Consensus.BlockTree
  ( BlockTree (BlockTree, btTrunk, btBranches)
  , BlockTreeBranch (..)
  , PathAnchoredAtSource (..)
  , addBranch
  , addBranch'
  , allFragments
  , deforestBlockTree
  , findFragment
  , findPath
  , isAncestorOf
  , isStrictAncestorOf
  , mkTrunk
  , nonemptyPrefixesOf
  , onTrunk
  , prettyBlockTree
  ) where

import Cardano.Slotting.Slot (SlotNo (unSlotNo), WithOrigin (..))
import Data.Foldable (asum, fold)
import Data.Function ((&))
import Data.Functor ((<&>))
import Data.List (inits, sortOn)
import qualified Data.Map.Strict as M
import Data.Maybe (fromJust, fromMaybe)
import Data.Ord (Down (Down))
import qualified Data.Vector as Vector
import Ouroboros.Consensus.Block.Abstract
  ( GetHeader (..)
  , HasHeader
  , Header
  , HeaderHash
  , Point
  , blockHash
  , blockNo
  , blockSlot
  , fromWithOrigin
  , pointSlot
  , unBlockNo
  )
import qualified Ouroboros.Network.AnchoredFragment as AF
import Text.Printf (printf)

-- | Represent a branch of a block tree by a prefix and a suffix. The full
-- fragment (the prefix and suffix catenated) and the trunk suffix (the rest of
-- the trunk after the branch forks off) are provided for practicality.
--
-- INVARIANT: the head of @btbPrefix@ is the anchor of @btbSuffix@.
--
-- INVARIANT: @btbFull == fromJust $ AF.join btbPrefix btbSuffix@.
data BlockTreeBranch blk = BlockTreeBranch
  { forall blk. BlockTreeBranch blk -> AnchoredFragment blk
btbPrefix :: AF.AnchoredFragment blk
  , forall blk. BlockTreeBranch blk -> AnchoredFragment blk
btbSuffix :: AF.AnchoredFragment blk
  , forall blk. BlockTreeBranch blk -> AnchoredFragment blk
btbTrunkSuffix :: AF.AnchoredFragment blk
  , forall blk. BlockTreeBranch blk -> AnchoredFragment blk
btbFull :: AF.AnchoredFragment blk
  }
  deriving Int -> BlockTreeBranch blk -> ShowS
[BlockTreeBranch blk] -> ShowS
BlockTreeBranch blk -> String
(Int -> BlockTreeBranch blk -> ShowS)
-> (BlockTreeBranch blk -> String)
-> ([BlockTreeBranch blk] -> ShowS)
-> Show (BlockTreeBranch blk)
forall blk.
(StandardHash blk, Show blk) =>
Int -> BlockTreeBranch blk -> ShowS
forall blk.
(StandardHash blk, Show blk) =>
[BlockTreeBranch blk] -> ShowS
forall blk.
(StandardHash blk, Show blk) =>
BlockTreeBranch blk -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall blk.
(StandardHash blk, Show blk) =>
Int -> BlockTreeBranch blk -> ShowS
showsPrec :: Int -> BlockTreeBranch blk -> ShowS
$cshow :: forall blk.
(StandardHash blk, Show blk) =>
BlockTreeBranch blk -> String
show :: BlockTreeBranch blk -> String
$cshowList :: forall blk.
(StandardHash blk, Show blk) =>
[BlockTreeBranch blk] -> ShowS
showList :: [BlockTreeBranch blk] -> ShowS
Show

-- | Represent a block tree with a main trunk and branches leaving from the
-- trunk in question. All the branches are represented by their prefix to and
-- suffix from the intersection point.
--
-- INVARIANT: The branches' prefixes share the same anchor as the trunk and are
-- fully contained in the trunk.
--
-- INVARIANT: The branches' suffixes are anchored in the trunk and do not
-- contain any blocks in common with the trunk.
--
-- INVARIANT: The branches' suffixes do not contain any block in common with one
-- another.
--
-- INVARIANT: for all @BlockTreeBranch{..}@ in the tree, @btTrunk == fromJust $
-- AF.join btbPrefix btbTrunkSuffix@.
--
-- INVARIANT: In @RawBlockTree trunk branches deforested@, we must have
-- @deforested == deforestRawBlockTree trunk branches@.
--
-- REVIEW: Find another name so as not to clash with 'BlockTree' from
-- `unstable-consensus-testlib/Test/Util/TestBlock.hs`.
data BlockTree blk = RawBlockTree
  { forall blk. BlockTree blk -> AnchoredFragment blk
btTrunk' :: AF.AnchoredFragment blk
  , forall blk. BlockTree blk -> [BlockTreeBranch blk]
btBranches' :: [BlockTreeBranch blk]
  , -- Cached deforestation of the block tree. This gets queried
    -- many times and there's no reason to rebuild the tree every time.
    forall blk. BlockTree blk -> DeforestedBlockTree blk
btDeforested :: DeforestedBlockTree blk
  }
  deriving Int -> BlockTree blk -> ShowS
[BlockTree blk] -> ShowS
BlockTree blk -> String
(Int -> BlockTree blk -> ShowS)
-> (BlockTree blk -> String)
-> ([BlockTree blk] -> ShowS)
-> Show (BlockTree blk)
forall blk.
(StandardHash blk, Show blk) =>
Int -> BlockTree blk -> ShowS
forall blk.
(StandardHash blk, Show blk) =>
[BlockTree blk] -> ShowS
forall blk. (StandardHash blk, Show blk) => BlockTree blk -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall blk.
(StandardHash blk, Show blk) =>
Int -> BlockTree blk -> ShowS
showsPrec :: Int -> BlockTree blk -> ShowS
$cshow :: forall blk. (StandardHash blk, Show blk) => BlockTree blk -> String
show :: BlockTree blk -> String
$cshowList :: forall blk.
(StandardHash blk, Show blk) =>
[BlockTree blk] -> ShowS
showList :: [BlockTree blk] -> ShowS
Show

pattern BlockTree :: AF.AnchoredFragment blk -> [BlockTreeBranch blk] -> BlockTree blk
pattern $mBlockTree :: forall {r} {blk}.
BlockTree blk
-> (AnchoredFragment blk -> [BlockTreeBranch blk] -> r)
-> ((# #) -> r)
-> r
BlockTree{forall blk. BlockTree blk -> AnchoredFragment blk
btTrunk, forall blk. BlockTree blk -> [BlockTreeBranch blk]
btBranches} <- RawBlockTree btTrunk btBranches _

{-# COMPLETE BlockTree #-}

deforestBlockTree :: BlockTree blk -> DeforestedBlockTree blk
deforestBlockTree :: forall blk. BlockTree blk -> DeforestedBlockTree blk
deforestBlockTree = BlockTree blk -> DeforestedBlockTree blk
forall blk. BlockTree blk -> DeforestedBlockTree blk
btDeforested

-- Smart constructor to cache the deforested block tree at creation time.
mkBlockTree :: HasHeader blk => AF.AnchoredFragment blk -> [BlockTreeBranch blk] -> BlockTree blk
mkBlockTree :: forall blk.
HasHeader blk =>
AnchoredFragment blk -> [BlockTreeBranch blk] -> BlockTree blk
mkBlockTree AnchoredFragment blk
trunk [BlockTreeBranch blk]
branches = AnchoredFragment blk
-> [BlockTreeBranch blk]
-> DeforestedBlockTree blk
-> BlockTree blk
forall blk.
AnchoredFragment blk
-> [BlockTreeBranch blk]
-> DeforestedBlockTree blk
-> BlockTree blk
RawBlockTree AnchoredFragment blk
trunk [BlockTreeBranch blk]
branches (AnchoredFragment blk
-> [BlockTreeBranch blk] -> DeforestedBlockTree blk
forall blk.
HasHeader blk =>
AnchoredFragment blk
-> [BlockTreeBranch blk] -> DeforestedBlockTree blk
deforestRawBlockTree AnchoredFragment blk
trunk [BlockTreeBranch blk]
branches)

-- | Make a block tree made of only a trunk.
mkTrunk :: HasHeader blk => AF.AnchoredFragment blk -> BlockTree blk
mkTrunk :: forall blk. HasHeader blk => AnchoredFragment blk -> BlockTree blk
mkTrunk AnchoredFragment blk
btTrunk = AnchoredFragment blk -> [BlockTreeBranch blk] -> BlockTree blk
forall blk.
HasHeader blk =>
AnchoredFragment blk -> [BlockTreeBranch blk] -> BlockTree blk
mkBlockTree AnchoredFragment blk
btTrunk []

-- | Add a branch to an existing block tree.
--
-- Yields @Nothing@ if the given fragment does not intersect with the trunk or its anchor.
--
-- FIXME: we should enforce that the branch's prefix shares the same anchor as
-- the trunk.
--
-- FIXME: we should enforce that the new branch' suffix does not contain any
-- block in common with an existing branch.
addBranch :: AF.HasHeader blk => AF.AnchoredFragment blk -> BlockTree blk -> Maybe (BlockTree blk)
addBranch :: forall blk.
HasHeader blk =>
AnchoredFragment blk -> BlockTree blk -> Maybe (BlockTree blk)
addBranch AnchoredFragment blk
branch BlockTree blk
bt = do
  (btbPrefix, _, btbTrunkSuffix, btbSuffix) <- AnchoredFragment blk
-> AnchoredFragment blk
-> Maybe
     (AnchoredFragment blk, AnchoredFragment blk, AnchoredFragment blk,
      AnchoredFragment blk)
forall block1 block2.
(HasHeader block1, HasHeader block2,
 HeaderHash block1 ~ HeaderHash block2) =>
AnchoredFragment block1
-> AnchoredFragment block2
-> Maybe
     (AnchoredFragment block1, AnchoredFragment block2,
      AnchoredFragment block1, AnchoredFragment block2)
AF.intersect (BlockTree blk -> AnchoredFragment blk
forall blk. BlockTree blk -> AnchoredFragment blk
btTrunk BlockTree blk
bt) AnchoredFragment blk
branch
  -- NOTE: We could use the monadic bind for @Maybe@ here but we would rather
  -- catch bugs quicker.
  let btbFull = Maybe (AnchoredFragment blk) -> AnchoredFragment blk
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (AnchoredFragment blk) -> AnchoredFragment blk)
-> Maybe (AnchoredFragment blk) -> AnchoredFragment blk
forall a b. (a -> b) -> a -> b
$ AnchoredFragment blk
-> AnchoredFragment blk -> Maybe (AnchoredFragment blk)
forall block.
HasHeader block =>
AnchoredFragment block
-> AnchoredFragment block -> Maybe (AnchoredFragment block)
AF.join AnchoredFragment blk
btbPrefix AnchoredFragment blk
btbSuffix
  pure $ mkBlockTree (btTrunk bt) (BlockTreeBranch{..} : btBranches bt)

-- | Same as @addBranch@ but calls to 'error' if the former yields 'Nothing'.
addBranch' :: AF.HasHeader blk => AF.AnchoredFragment blk -> BlockTree blk -> BlockTree blk
addBranch' :: forall blk.
HasHeader blk =>
AnchoredFragment blk -> BlockTree blk -> BlockTree blk
addBranch' AnchoredFragment blk
branch BlockTree blk
blockTree =
  BlockTree blk -> Maybe (BlockTree blk) -> BlockTree blk
forall a. a -> Maybe a -> a
fromMaybe (String -> BlockTree blk
forall a. HasCallStack => String -> a
error String
"addBranch': precondition does not hold") (Maybe (BlockTree blk) -> BlockTree blk)
-> Maybe (BlockTree blk) -> BlockTree blk
forall a b. (a -> b) -> a -> b
$ AnchoredFragment blk -> BlockTree blk -> Maybe (BlockTree blk)
forall blk.
HasHeader blk =>
AnchoredFragment blk -> BlockTree blk -> Maybe (BlockTree blk)
addBranch AnchoredFragment blk
branch BlockTree blk
blockTree

-- | Return all the full fragments from the root of the tree.
allFragments :: BlockTree blk -> [AF.AnchoredFragment blk]
allFragments :: forall blk. BlockTree blk -> [AnchoredFragment blk]
allFragments BlockTree blk
bt = BlockTree blk -> AnchoredFragment blk
forall blk. BlockTree blk -> AnchoredFragment blk
btTrunk BlockTree blk
bt AnchoredFragment blk
-> [AnchoredFragment blk] -> [AnchoredFragment blk]
forall a. a -> [a] -> [a]
: (BlockTreeBranch blk -> AnchoredFragment blk)
-> [BlockTreeBranch blk] -> [AnchoredFragment blk]
forall a b. (a -> b) -> [a] -> [b]
map BlockTreeBranch blk -> AnchoredFragment blk
forall blk. BlockTreeBranch blk -> AnchoredFragment blk
btbFull (BlockTree blk -> [BlockTreeBranch blk]
forall blk. BlockTree blk -> [BlockTreeBranch blk]
btBranches BlockTree blk
bt)

-- | Look for a point in the block tree and return a fragment going from the
-- root of the tree to the point in question.
findFragment :: AF.HasHeader blk => AF.Point blk -> BlockTree blk -> Maybe (AF.AnchoredFragment blk)
findFragment :: forall blk.
HasHeader blk =>
Point blk -> BlockTree blk -> Maybe (AnchoredFragment blk)
findFragment Point blk
point BlockTree blk
blockTree =
  BlockTree blk -> [AnchoredFragment blk]
forall blk. BlockTree blk -> [AnchoredFragment blk]
allFragments BlockTree blk
blockTree
    [AnchoredFragment blk]
-> ([AnchoredFragment blk]
    -> [Maybe (AnchoredFragment blk, AnchoredFragment blk)])
-> [Maybe (AnchoredFragment blk, AnchoredFragment blk)]
forall a b. a -> (a -> b) -> b
& (AnchoredFragment blk
 -> Maybe (AnchoredFragment blk, AnchoredFragment blk))
-> [AnchoredFragment blk]
-> [Maybe (AnchoredFragment blk, AnchoredFragment blk)]
forall a b. (a -> b) -> [a] -> [b]
map (\AnchoredFragment blk
fragment -> AnchoredFragment blk
-> Point blk -> Maybe (AnchoredFragment blk, AnchoredFragment blk)
forall block1 block2.
(HasHeader block1, HeaderHash block1 ~ HeaderHash block2) =>
AnchoredFragment block1
-> Point block2
-> Maybe (AnchoredFragment block1, AnchoredFragment block1)
AF.splitAfterPoint AnchoredFragment blk
fragment Point blk
point)
    [Maybe (AnchoredFragment blk, AnchoredFragment blk)]
-> ([Maybe (AnchoredFragment blk, AnchoredFragment blk)]
    -> Maybe (AnchoredFragment blk, AnchoredFragment blk))
-> Maybe (AnchoredFragment blk, AnchoredFragment blk)
forall a b. a -> (a -> b) -> b
& [Maybe (AnchoredFragment blk, AnchoredFragment blk)]
-> Maybe (AnchoredFragment blk, AnchoredFragment blk)
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
    Maybe (AnchoredFragment blk, AnchoredFragment blk)
-> ((AnchoredFragment blk, AnchoredFragment blk)
    -> AnchoredFragment blk)
-> Maybe (AnchoredFragment blk)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (AnchoredFragment blk, AnchoredFragment blk)
-> AnchoredFragment blk
forall a b. (a, b) -> a
fst

-- | See 'findPath'.
newtype PathAnchoredAtSource = PathAnchoredAtSource Bool

-- | @findPath source target blockTree@ finds a path from the @source@ point to
-- the @target@ point in the @blockTree@ and returns it as an anchored fragment
-- It returns @Nothing@ when either of @source@ are @target@ are not in the
-- 'BlockTree'. There are two interesting properties on this fragment:
--
--   1. Whether the returned fragment is anchored at the @source@.
--   2. Whether the returned fragment is empty.
--
-- Together, those two properties form four interesting cases:
--
--   a. If the fragment is anchored at the @source@ and is empty, then @source
--      == target@.
--
--   b. If the fragment is anchored at the @source@ and is not empty, then
--      @source@ is an ancestor of @target@ and the fragment contains all the
--      blocks between them, @target@ included.
--
--   c. If the fragment is not anchored at the @source@ and is empty, then
--      @target@ is an ancestor of @source@.
--
--   d. If the fragment is not anchored at the @source@ and is not empty, then
--      it is anchored at the youngest common ancestor of both @source@ and
--      @target@ and contains all the blocks between that ancestor and @target@.
findPath ::
  AF.HasHeader blk =>
  AF.Point blk ->
  AF.Point blk ->
  BlockTree blk ->
  Maybe (PathAnchoredAtSource, AF.AnchoredFragment blk)
findPath :: forall blk.
HasHeader blk =>
Point blk
-> Point blk
-> BlockTree blk
-> Maybe (PathAnchoredAtSource, AnchoredFragment blk)
findPath Point blk
source Point blk
target BlockTree blk
blockTree = do
  sourceFragment <- Point blk -> BlockTree blk -> Maybe (AnchoredFragment blk)
forall blk.
HasHeader blk =>
Point blk -> BlockTree blk -> Maybe (AnchoredFragment blk)
findFragment Point blk
source BlockTree blk
blockTree
  targetFragment <- findFragment target blockTree
  (_, _, _, targetSuffix) <- AF.intersect sourceFragment targetFragment
  pure
    ( PathAnchoredAtSource (AF.anchorPoint targetSuffix == source)
    , targetSuffix
    )

-- | Pretty prints a block tree for human readability. For instance:
--
--     slots:  0  1  2  3  4  5  6  7  8  9
--     trunk:  0─────1──2──3──4─────5──6──7
--                      ╰─────3──4─────5
--
-- Returns a list of strings intended to be catenated with a newline.
prettyBlockTree :: AF.HasHeader blk => BlockTree blk -> [String]
prettyBlockTree :: forall blk. HasHeader blk => BlockTree blk -> [String]
prettyBlockTree BlockTree blk
blockTree =
  [String
"slots:   " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords ((SlotNo -> String) -> [SlotNo] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Word64 -> String
forall r. PrintfType r => String -> r
printf String
"%2d" (Word64 -> String) -> (SlotNo -> Word64) -> SlotNo -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SlotNo -> Word64
unSlotNo) [SlotNo
veryFirstSlot .. SlotNo
veryLastSlot])]
    [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [AnchoredFragment blk -> String
forall blk. HasHeader blk => AnchoredFragment blk -> String
printTrunk AnchoredFragment blk
honestFragment]
    [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (((Int, AnchoredFragment blk) -> String)
-> [(Int, AnchoredFragment blk)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((Int -> AnchoredFragment blk -> String)
-> (Int, AnchoredFragment blk) -> String
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> AnchoredFragment blk -> String
forall blk. HasHeader blk => Int -> AnchoredFragment blk -> String
printBranch) [(Int, AnchoredFragment blk)]
adversarialFragments)
 where
  honestFragment :: AnchoredFragment blk
honestFragment = BlockTree blk -> AnchoredFragment blk
forall blk. BlockTree blk -> AnchoredFragment blk
btTrunk BlockTree blk
blockTree
  adversarialFragments :: [(Int, AnchoredFragment blk)]
adversarialFragments =
    ((Int, AnchoredFragment blk) -> Down (WithOrigin SlotNo))
-> [(Int, AnchoredFragment blk)] -> [(Int, AnchoredFragment blk)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (WithOrigin SlotNo -> Down (WithOrigin SlotNo)
forall a. a -> Down a
Down (WithOrigin SlotNo -> Down (WithOrigin SlotNo))
-> ((Int, AnchoredFragment blk) -> WithOrigin SlotNo)
-> (Int, AnchoredFragment blk)
-> Down (WithOrigin SlotNo)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point blk -> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot (Point blk -> WithOrigin SlotNo)
-> ((Int, AnchoredFragment blk) -> Point blk)
-> (Int, AnchoredFragment blk)
-> WithOrigin SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredFragment blk -> Point blk
forall block. AnchoredFragment block -> Point block
AF.anchorPoint (AnchoredFragment blk -> Point blk)
-> ((Int, AnchoredFragment blk) -> AnchoredFragment blk)
-> (Int, AnchoredFragment blk)
-> Point blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, AnchoredFragment blk) -> AnchoredFragment blk
forall a b. (a, b) -> b
snd) ([(Int, AnchoredFragment blk)] -> [(Int, AnchoredFragment blk)])
-> [(Int, AnchoredFragment blk)] -> [(Int, AnchoredFragment blk)]
forall a b. (a -> b) -> a -> b
$
      [Int] -> [AnchoredFragment blk] -> [(Int, AnchoredFragment blk)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 ..] ([AnchoredFragment blk] -> [(Int, AnchoredFragment blk)])
-> [AnchoredFragment blk] -> [(Int, AnchoredFragment blk)]
forall a b. (a -> b) -> a -> b
$
        (BlockTreeBranch blk -> AnchoredFragment blk)
-> [BlockTreeBranch blk] -> [AnchoredFragment blk]
forall a b. (a -> b) -> [a] -> [b]
map BlockTreeBranch blk -> AnchoredFragment blk
forall blk. BlockTreeBranch blk -> AnchoredFragment blk
btbSuffix (BlockTree blk -> [BlockTreeBranch blk]
forall blk. BlockTree blk -> [BlockTreeBranch blk]
btBranches BlockTree blk
blockTree)

  veryFirstSlot :: SlotNo
veryFirstSlot = AnchoredFragment blk -> SlotNo
forall blk. AnchoredFragment blk -> SlotNo
firstNo (AnchoredFragment blk -> SlotNo) -> AnchoredFragment blk -> SlotNo
forall a b. (a -> b) -> a -> b
$ AnchoredFragment blk
honestFragment

  veryLastSlot :: SlotNo
veryLastSlot =
    (SlotNo -> SlotNo -> SlotNo) -> SlotNo -> [SlotNo] -> SlotNo
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl SlotNo -> SlotNo -> SlotNo
forall a. Ord a => a -> a -> a
max SlotNo
0 ([SlotNo] -> SlotNo) -> [SlotNo] -> SlotNo
forall a b. (a -> b) -> a -> b
$
      (AnchoredFragment blk -> SlotNo)
-> [AnchoredFragment blk] -> [SlotNo]
forall a b. (a -> b) -> [a] -> [b]
map
        AnchoredFragment blk -> SlotNo
forall blk. HasHeader blk => AnchoredFragment blk -> SlotNo
lastNo
        (AnchoredFragment blk
honestFragment AnchoredFragment blk
-> [AnchoredFragment blk] -> [AnchoredFragment blk]
forall a. a -> [a] -> [a]
: ((Int, AnchoredFragment blk) -> AnchoredFragment blk)
-> [(Int, AnchoredFragment blk)] -> [AnchoredFragment blk]
forall a b. (a -> b) -> [a] -> [b]
map (Int, AnchoredFragment blk) -> AnchoredFragment blk
forall a b. (a, b) -> b
snd [(Int, AnchoredFragment blk)]
adversarialFragments)

  printTrunk :: AF.HasHeader blk => AF.AnchoredFragment blk -> String
  printTrunk :: forall blk. HasHeader blk => AnchoredFragment blk -> String
printTrunk = (SlotNo -> String) -> AnchoredFragment blk -> String
forall blk.
HasHeader blk =>
(SlotNo -> String) -> AnchoredFragment blk -> String
printLine (\SlotNo
_ -> String
"trunk:  ─")

  printBranch :: AF.HasHeader blk => Int -> AF.AnchoredFragment blk -> String
  printBranch :: forall blk. HasHeader blk => Int -> AnchoredFragment blk -> String
printBranch Int
idx = (SlotNo -> String) -> AnchoredFragment blk -> String
forall blk.
HasHeader blk =>
(SlotNo -> String) -> AnchoredFragment blk -> String
printLine ((SlotNo -> String) -> AnchoredFragment blk -> String)
-> (SlotNo -> String) -> AnchoredFragment blk -> String
forall a b. (a -> b) -> a -> b
$ \SlotNo
firstSlot ->
    let sidx :: String
sidx = String
"  (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
idx String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
        pad :: String
pad = Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
6 Char
' '
        prefix :: String
prefix = String
sidx String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> ShowS
forall a. Int -> [a] -> [a]
drop (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
sidx) String
pad
     in String
prefix String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (SlotNo -> Word64
unSlotNo (SlotNo
firstSlot SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
- SlotNo
veryFirstSlot))) Char
' ' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" ╰─"

  printLine :: AF.HasHeader blk => (SlotNo -> String) -> AF.AnchoredFragment blk -> String
  printLine :: forall blk.
HasHeader blk =>
(SlotNo -> String) -> AnchoredFragment blk -> String
printLine SlotNo -> String
printHeader AnchoredFragment blk
fragment =
    let firstSlot :: SlotNo
firstSlot = AnchoredFragment blk -> SlotNo
forall blk. AnchoredFragment blk -> SlotNo
firstNo AnchoredFragment blk
fragment
        lastSlot :: SlotNo
lastSlot = AnchoredFragment blk -> SlotNo
forall blk. HasHeader blk => AnchoredFragment blk -> SlotNo
lastNo AnchoredFragment blk
fragment
     in SlotNo -> String
printHeader SlotNo
firstSlot String -> ShowS
forall a. [a] -> [a] -> [a]
++ SlotNo -> SlotNo -> AnchoredFragment blk -> String
forall blk.
HasHeader blk =>
SlotNo -> SlotNo -> AnchoredFragment blk -> String
printFragment SlotNo
firstSlot SlotNo
lastSlot AnchoredFragment blk
fragment

  printFragment :: AF.HasHeader blk => SlotNo -> SlotNo -> AF.AnchoredFragment blk -> String
  printFragment :: forall blk.
HasHeader blk =>
SlotNo -> SlotNo -> AnchoredFragment blk -> String
printFragment SlotNo
firstSlot SlotNo
lastSlot AnchoredFragment blk
fragment =
    AnchoredFragment blk
fragment
      AnchoredFragment blk -> (AnchoredFragment blk -> [blk]) -> [blk]
forall a b. a -> (a -> b) -> b
& AnchoredFragment blk -> [blk]
forall v a b. AnchoredSeq v a b -> [b]
AF.toOldestFirst
      -- Turn the fragment into a list of (SlotNo, Just BlockNo)
      [blk] -> ([blk] -> [(Int, Maybe Word64)]) -> [(Int, Maybe Word64)]
forall a b. a -> (a -> b) -> b
& (blk -> (Int, Maybe Word64)) -> [blk] -> [(Int, Maybe Word64)]
forall a b. (a -> b) -> [a] -> [b]
map
        ( \blk
block ->
            (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (SlotNo -> Word64
unSlotNo (blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot blk
block) Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- SlotNo -> Word64
unSlotNo SlotNo
firstSlot), Word64 -> Maybe Word64
forall a. a -> Maybe a
Just (BlockNo -> Word64
unBlockNo (blk -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo blk
block)))
        )
      -- Update only the Vector elements that have blocks in them
      [(Int, Maybe Word64)]
-> ([(Int, Maybe Word64)] -> [Maybe Word64]) -> [Maybe Word64]
forall a b. a -> (a -> b) -> b
& Vector (Maybe Word64) -> [Maybe Word64]
forall a. Vector a -> [a]
Vector.toList (Vector (Maybe Word64) -> [Maybe Word64])
-> ([(Int, Maybe Word64)] -> Vector (Maybe Word64))
-> [(Int, Maybe Word64)]
-> [Maybe Word64]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Vector (Maybe Word64)
forall {a}. Vector (Maybe a)
slotRange Vector (Maybe Word64)
-> [(Int, Maybe Word64)] -> Vector (Maybe Word64)
forall a. Vector a -> [(Int, a)] -> Vector a
Vector.//)
      [Maybe Word64] -> ([Maybe Word64] -> [String]) -> [String]
forall a b. a -> (a -> b) -> b
& (Maybe Word64 -> String) -> [Maybe Word64] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> (Word64 -> String) -> Maybe Word64 -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"  " (String -> Word64 -> String
forall r. PrintfType r => String -> r
printf String
"%2d"))
      [String] -> ([String] -> String) -> String
forall a b. a -> (a -> b) -> b
& [String] -> String
unwords
      String -> ShowS -> String
forall a b. a -> (a -> b) -> b
& (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map (\Char
c -> if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' then Char
'─' else Char
c)
   where
    -- Initialize a Vector with the length of the fragment containing only Nothings
    slotRange :: Vector (Maybe a)
slotRange = Int -> Maybe a -> Vector (Maybe a)
forall a. Int -> a -> Vector a
Vector.replicate (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (SlotNo -> Word64
unSlotNo SlotNo
lastSlot Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- SlotNo -> Word64
unSlotNo SlotNo
firstSlot Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1)) Maybe a
forall a. Maybe a
Nothing

  lastNo :: AF.HasHeader blk => AF.AnchoredFragment blk -> SlotNo
  lastNo :: forall blk. HasHeader blk => AnchoredFragment blk -> SlotNo
lastNo = SlotNo -> WithOrigin SlotNo -> SlotNo
forall t. t -> WithOrigin t -> t
fromWithOrigin SlotNo
0 (WithOrigin SlotNo -> SlotNo)
-> (AnchoredFragment blk -> WithOrigin SlotNo)
-> AnchoredFragment blk
-> SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredFragment blk -> WithOrigin SlotNo
forall block.
HasHeader block =>
AnchoredFragment block -> WithOrigin SlotNo
AF.headSlot

  firstNo :: AF.AnchoredFragment blk -> SlotNo
  firstNo :: forall blk. AnchoredFragment blk -> SlotNo
firstNo AnchoredFragment blk
frag =
    case AnchoredFragment blk -> Anchor blk
forall v a b. AnchoredSeq v a b -> a
AF.anchor AnchoredFragment blk
frag of
      Anchor blk
AF.AnchorGenesis -> SlotNo
0
      AF.Anchor SlotNo
slotNo HeaderHash blk
_ BlockNo
_ -> SlotNo
slotNo SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+ SlotNo
1

-- | An 'AF.AnchoredFragment' is a list where the last element (the anchor) is a ghost.
-- Here they represent the partial ancestry of a block, where the anchor is either
-- @Genesis@ (start of the chain, not itself an actual block) or the hash of a block.
-- Say we have blocks B1 through B5 (each succeeded by the next) and anchor A. You
-- can think of the chain as growing __from left to right__ like this:
--
-- >                    A :> B1 :> B2 :> B3 :> B4 :> B5
--
-- 'nonemptyPrefixesOf' builds the list of prefixes of an 'AF.AnchoredFragment' with at
-- least one non-anchor entry. The name is a little confusing because the way we
-- usually think of cons-lists these would be suffixes:
--
-- >            A :> B1     A :> B1 :> B2     A :> B1 :> B2 :> B3
-- >      A :> B1 :> B2 :> B3 :> B4     A :> B1 :> B2 :> B3 :> B4 :> B5
--
-- However this is consistent with 'Ouroboros.Network.AnchoredSeq.isPrefixOf'.
nonemptyPrefixesOf ::
  AF.HasHeader blk => AF.AnchoredFragment blk -> [AF.AnchoredFragment blk]
nonemptyPrefixesOf :: forall blk.
HasHeader blk =>
AnchoredFragment blk -> [AnchoredFragment blk]
nonemptyPrefixesOf AnchoredFragment blk
frag =
  ([blk] -> AnchoredFragment blk)
-> [[blk]] -> [AnchoredFragment blk]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Anchor blk -> [blk] -> AnchoredFragment blk
forall v a b. Anchorable v a b => a -> [b] -> AnchoredSeq v a b
AF.fromOldestFirst (AnchoredFragment blk -> Anchor blk
forall v a b. AnchoredSeq v a b -> a
AF.anchor AnchoredFragment blk
frag)) ([[blk]] -> [AnchoredFragment blk])
-> (AnchoredFragment blk -> [[blk]])
-> AnchoredFragment blk
-> [AnchoredFragment blk]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [[blk]] -> [[blk]]
forall a. Int -> [a] -> [a]
drop Int
1 ([[blk]] -> [[blk]])
-> (AnchoredFragment blk -> [[blk]])
-> AnchoredFragment blk
-> [[blk]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [blk] -> [[blk]]
forall a. [a] -> [[a]]
inits ([blk] -> [[blk]])
-> (AnchoredFragment blk -> [blk])
-> AnchoredFragment blk
-> [[blk]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredFragment blk -> [blk]
forall v a b. AnchoredSeq v a b -> [b]
AF.toOldestFirst (AnchoredFragment blk -> [AnchoredFragment blk])
-> AnchoredFragment blk -> [AnchoredFragment blk]
forall a b. (a -> b) -> a -> b
$ AnchoredFragment blk
frag

type DeforestedBlockTree blk = M.Map (HeaderHash blk) (AF.AnchoredFragment blk)

deforestRawBlockTree ::
  HasHeader blk =>
  AF.AnchoredFragment blk ->
  [BlockTreeBranch blk] ->
  DeforestedBlockTree blk
deforestRawBlockTree :: forall blk.
HasHeader blk =>
AnchoredFragment blk
-> [BlockTreeBranch blk] -> DeforestedBlockTree blk
deforestRawBlockTree AnchoredFragment blk
trunk [BlockTreeBranch blk]
branches =
  let folder :: [AnchoredFragment blk]
-> Map (HeaderHash blk) (AnchoredFragment blk)
folder = (AnchoredFragment blk
 -> Map (HeaderHash blk) (AnchoredFragment blk))
-> [AnchoredFragment blk]
-> Map (HeaderHash blk) (AnchoredFragment blk)
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((AnchoredFragment blk
  -> Map (HeaderHash blk) (AnchoredFragment blk))
 -> [AnchoredFragment blk]
 -> Map (HeaderHash blk) (AnchoredFragment blk))
-> (AnchoredFragment blk
    -> Map (HeaderHash blk) (AnchoredFragment blk))
-> [AnchoredFragment blk]
-> Map (HeaderHash blk) (AnchoredFragment blk)
forall a b. (a -> b) -> a -> b
$ \AnchoredFragment blk
af -> (Anchor blk -> Map (HeaderHash blk) (AnchoredFragment blk))
-> (blk -> Map (HeaderHash blk) (AnchoredFragment blk))
-> Either (Anchor blk) blk
-> Map (HeaderHash blk) (AnchoredFragment blk)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Map (HeaderHash blk) (AnchoredFragment blk)
-> Anchor blk -> Map (HeaderHash blk) (AnchoredFragment blk)
forall a b. a -> b -> a
const Map (HeaderHash blk) (AnchoredFragment blk)
forall a. Monoid a => a
mempty) ((HeaderHash blk
 -> AnchoredFragment blk
 -> Map (HeaderHash blk) (AnchoredFragment blk))
-> AnchoredFragment blk
-> HeaderHash blk
-> Map (HeaderHash blk) (AnchoredFragment blk)
forall a b c. (a -> b -> c) -> b -> a -> c
flip HeaderHash blk
-> AnchoredFragment blk
-> Map (HeaderHash blk) (AnchoredFragment blk)
forall k a. k -> a -> Map k a
M.singleton AnchoredFragment blk
af (HeaderHash blk -> Map (HeaderHash blk) (AnchoredFragment blk))
-> (blk -> HeaderHash blk)
-> blk
-> Map (HeaderHash blk) (AnchoredFragment blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. blk -> HeaderHash blk
forall b. HasHeader b => b -> HeaderHash b
blockHash) (Either (Anchor blk) blk
 -> Map (HeaderHash blk) (AnchoredFragment blk))
-> Either (Anchor blk) blk
-> Map (HeaderHash blk) (AnchoredFragment blk)
forall a b. (a -> b) -> a -> b
$ AnchoredFragment blk -> Either (Anchor blk) blk
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Either a b
AF.head AnchoredFragment blk
af
   in [Map (HeaderHash blk) (AnchoredFragment blk)]
-> Map (HeaderHash blk) (AnchoredFragment blk)
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ([Map (HeaderHash blk) (AnchoredFragment blk)]
 -> Map (HeaderHash blk) (AnchoredFragment blk))
-> [Map (HeaderHash blk) (AnchoredFragment blk)]
-> Map (HeaderHash blk) (AnchoredFragment blk)
forall a b. (a -> b) -> a -> b
$
        [AnchoredFragment blk]
-> Map (HeaderHash blk) (AnchoredFragment blk)
folder (AnchoredFragment blk -> [blk] -> [AnchoredFragment blk]
forall blk.
HasHeader blk =>
AnchoredFragment blk -> [blk] -> [AnchoredFragment blk]
prefixes (Anchor blk -> AnchoredFragment blk
forall v a b. Anchorable v a b => a -> AnchoredSeq v a b
AF.Empty Anchor blk
forall block. Anchor block
AF.AnchorGenesis) ([blk] -> [AnchoredFragment blk])
-> [blk] -> [AnchoredFragment blk]
forall a b. (a -> b) -> a -> b
$ AnchoredFragment blk -> [blk]
forall v a b. AnchoredSeq v a b -> [b]
AF.toOldestFirst AnchoredFragment blk
trunk)
          Map (HeaderHash blk) (AnchoredFragment blk)
-> [Map (HeaderHash blk) (AnchoredFragment blk)]
-> [Map (HeaderHash blk) (AnchoredFragment blk)]
forall a. a -> [a] -> [a]
: (BlockTreeBranch blk
 -> Map (HeaderHash blk) (AnchoredFragment blk))
-> [BlockTreeBranch blk]
-> [Map (HeaderHash blk) (AnchoredFragment blk)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\BlockTreeBranch blk
btb -> [AnchoredFragment blk]
-> Map (HeaderHash blk) (AnchoredFragment blk)
folder ([AnchoredFragment blk]
 -> Map (HeaderHash blk) (AnchoredFragment blk))
-> [AnchoredFragment blk]
-> Map (HeaderHash blk) (AnchoredFragment blk)
forall a b. (a -> b) -> a -> b
$ AnchoredFragment blk -> [blk] -> [AnchoredFragment blk]
forall blk.
HasHeader blk =>
AnchoredFragment blk -> [blk] -> [AnchoredFragment blk]
prefixes (BlockTreeBranch blk -> AnchoredFragment blk
forall blk. BlockTreeBranch blk -> AnchoredFragment blk
btbPrefix BlockTreeBranch blk
btb) ([blk] -> [AnchoredFragment blk])
-> [blk] -> [AnchoredFragment blk]
forall a b. (a -> b) -> a -> b
$ AnchoredFragment blk -> [blk]
forall v a b. AnchoredSeq v a b -> [b]
AF.toOldestFirst (AnchoredFragment blk -> [blk]) -> AnchoredFragment blk -> [blk]
forall a b. (a -> b) -> a -> b
$ BlockTreeBranch blk -> AnchoredFragment blk
forall blk. BlockTreeBranch blk -> AnchoredFragment blk
btbSuffix BlockTreeBranch blk
btb) [BlockTreeBranch blk]
branches

prefixes :: AF.HasHeader blk => AF.AnchoredFragment blk -> [blk] -> [AF.AnchoredFragment blk]
prefixes :: forall blk.
HasHeader blk =>
AnchoredFragment blk -> [blk] -> [AnchoredFragment blk]
prefixes = (AnchoredFragment blk -> blk -> AnchoredFragment blk)
-> AnchoredFragment blk -> [blk] -> [AnchoredFragment blk]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl AnchoredFragment blk -> blk -> AnchoredFragment blk
forall v a b.
Anchorable v a b =>
AnchoredSeq v a b -> b -> AnchoredSeq v a b
(AF.:>)

-- | A check used in some of the handlers, determining whether the first argument
-- is on the chain that ends in the second argument.
--
-- REVIEW: Using 'AF.withinFragmentBounds' for this might be cheaper.
--
-- TODO: Unify with 'Test.Util.TestBlock.isAncestorOf' which basically does the
-- same thing except not on 'WithOrigin'.
isAncestorOf ::
  (HasHeader blk, Eq blk) =>
  BlockTree blk ->
  WithOrigin blk ->
  WithOrigin blk ->
  Bool
isAncestorOf :: forall blk.
(HasHeader blk, Eq blk) =>
BlockTree blk -> WithOrigin blk -> WithOrigin blk -> Bool
isAncestorOf BlockTree blk
tree (At blk
ancestor) (At blk
descendant) =
  let deforested :: DeforestedBlockTree blk
deforested = BlockTree blk -> DeforestedBlockTree blk
forall blk. BlockTree blk -> DeforestedBlockTree blk
btDeforested BlockTree blk
tree
   in Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ do
        afD <- HeaderHash blk
-> DeforestedBlockTree blk -> Maybe (AnchoredFragment blk)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (blk -> HeaderHash blk
forall b. HasHeader b => b -> HeaderHash b
blockHash blk
descendant) DeforestedBlockTree blk
deforested
        afA <- M.lookup (blockHash ancestor) deforested
        pure $ AF.isPrefixOf afA afD
isAncestorOf BlockTree blk
_ (At blk
_) WithOrigin blk
Origin = Bool
False
isAncestorOf BlockTree blk
_ WithOrigin blk
Origin WithOrigin blk
_ = Bool
True

-- | Variant of 'isAncestorOf' that returns @False@ when the two blocks are
-- equal.
--
-- TODO: Unify with 'Test.Util.TestBlock.isStrictAncestorOf' which basically does the
-- same thing except not on 'WithOrigin'.
isStrictAncestorOf ::
  (HasHeader blk, Eq blk) =>
  BlockTree blk ->
  WithOrigin blk ->
  WithOrigin blk ->
  Bool
isStrictAncestorOf :: forall blk.
(HasHeader blk, Eq blk) =>
BlockTree blk -> WithOrigin blk -> WithOrigin blk -> Bool
isStrictAncestorOf BlockTree blk
bt WithOrigin blk
b1 WithOrigin blk
b2 = WithOrigin blk
b1 WithOrigin blk -> WithOrigin blk -> Bool
forall a. Eq a => a -> a -> Bool
/= WithOrigin blk
b2 Bool -> Bool -> Bool
&& BlockTree blk -> WithOrigin blk -> WithOrigin blk -> Bool
forall blk.
(HasHeader blk, Eq blk) =>
BlockTree blk -> WithOrigin blk -> WithOrigin blk -> Bool
isAncestorOf BlockTree blk
bt WithOrigin blk
b1 WithOrigin blk
b2

-- | Check if a block (represented by its header 'Point') is on the 'BlockTree' trunk.
onTrunk :: GetHeader blk => BlockTree blk -> Point (Header blk) -> Bool
onTrunk :: forall blk.
GetHeader blk =>
BlockTree blk -> Point (Header blk) -> Bool
onTrunk BlockTree blk
blockTree = (Point (Header blk) -> AnchoredFragment (Header blk) -> Bool)
-> AnchoredFragment (Header blk) -> Point (Header blk) -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Point (Header blk) -> AnchoredFragment (Header blk) -> Bool
forall block.
HasHeader block =>
Point block -> AnchoredFragment block -> Bool
AF.withinFragmentBounds ((blk -> Header blk)
-> AnchoredFragment blk -> AnchoredFragment (Header blk)
forall block2 block1.
(HasHeader block2, HeaderHash block1 ~ HeaderHash block2) =>
(block1 -> block2)
-> AnchoredFragment block1 -> AnchoredFragment block2
AF.mapAnchoredFragment blk -> Header blk
forall blk. GetHeader blk => blk -> Header blk
getHeader (AnchoredFragment blk -> AnchoredFragment (Header blk))
-> AnchoredFragment blk -> AnchoredFragment (Header blk)
forall a b. (a -> b) -> a -> b
$ BlockTree blk -> AnchoredFragment blk
forall blk. BlockTree blk -> AnchoredFragment blk
btTrunk BlockTree blk
blockTree)