{-# LANGUAGE ScopedTypeVariables #-}

-- | Utility functions on anchored fragments
--
-- Intended for qualified import
-- > import qualified Ouroboros.Consensus.Util.AnchoredFragment as AF
module Ouroboros.Consensus.Util.AnchoredFragment (
    compareAnchoredFragments
  , compareHeadBlockNo
  , cross
  , forksAtMostKBlocks
  , preferAnchoredCandidate
  , stripCommonPrefix
  ) where

import           Control.Monad.Except (throwError)
import           Data.Foldable (toList)
import           Data.Function (on)
import qualified Data.List as L
import           Data.Maybe (isJust)
import           Data.Word (Word64)
import           GHC.Stack
import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Protocol.Abstract
import           Ouroboros.Consensus.Util.Assert
import           Ouroboros.Network.AnchoredFragment (AnchoredFragment,
                     AnchoredSeq (Empty, (:>)))
import qualified Ouroboros.Network.AnchoredFragment as AF

{-------------------------------------------------------------------------------
  Utility functions on anchored fragments
-------------------------------------------------------------------------------}

-- | Compare the 'headBlockNo', which is a measure of the length of the chain,
-- of two anchored fragments.
--
-- A fragment with a head is always \"greater\" than one without. When both
-- fragments have no head (i.e. are empty), they are 'EQ'.
--
-- Note that an EBB can share its @BlockNo@ with another regular block. If
-- such an EBB is the head of one fragment and the regular block with the same
-- @BlockNo@ is the head of the other fragment, then this function will say
-- they are 'EQ', while in fact one fragment should be preferred over the
-- other.
--
-- This is not a big deal as we won't be seeing new EBBs, so they will not be
-- the head of a fragment very often anyway, only when catching up. As soon as
-- a new block/header is added to the fragment, the right decision will be
-- made again ('GT' or 'LT').
compareHeadBlockNo ::
     HasHeader b
  => AnchoredFragment b
  -> AnchoredFragment b
  -> Ordering
compareHeadBlockNo :: forall b.
HasHeader b =>
AnchoredFragment b -> AnchoredFragment b -> Ordering
compareHeadBlockNo = WithOrigin BlockNo -> WithOrigin BlockNo -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (WithOrigin BlockNo -> WithOrigin BlockNo -> Ordering)
-> (AnchoredFragment b -> WithOrigin BlockNo)
-> AnchoredFragment b
-> AnchoredFragment b
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` AnchoredFragment b -> WithOrigin BlockNo
forall block.
HasHeader block =>
AnchoredFragment block -> WithOrigin BlockNo
AF.headBlockNo

forksAtMostKBlocks ::
     HasHeader b
  => Word64              -- ^ How many blocks can it fork?
  -> AnchoredFragment b  -- ^ Our chain.
  -> AnchoredFragment b  -- ^ Their chain
  -> Bool                -- ^ Indicates whether their chain forks at most the
                         -- specified number of blocks.
forksAtMostKBlocks :: forall b.
HasHeader b =>
Word64 -> AnchoredFragment b -> AnchoredFragment b -> Bool
forksAtMostKBlocks Word64
k AnchoredFragment b
ours AnchoredFragment b
theirs = case AnchoredFragment b
ours AnchoredFragment b
-> AnchoredFragment b
-> Maybe
     (AnchoredFragment b, AnchoredFragment b, AnchoredFragment b,
      AnchoredFragment b)
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` AnchoredFragment b
theirs of
    Maybe
  (AnchoredFragment b, AnchoredFragment b, AnchoredFragment b,
   AnchoredFragment b)
Nothing                   -> Bool
False
    Just (AnchoredFragment b
_, AnchoredFragment b
_, AnchoredFragment b
ourSuffix, AnchoredFragment b
_) -> Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (AnchoredFragment b -> Int
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Int
AF.length AnchoredFragment b
ourSuffix) Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word64
k

-- | Compare two (potentially empty!) 'AnchoredFragment's.
--
-- PRECONDITION: Either both fragments are non-empty or they intersect.
--
-- For a detailed discussion of this precondition, and a justification for the
-- definition of this function, please refer to the Consensus Report.
--
-- Usage note: the primary user of this function is the chain database when
-- sorting fragments that are preferred over our selection. It establishes the
-- precondition in the following way: It will only compare candidate fragments
-- that it has previously verified are preferable to our current chain. Since
-- these fragments intersect with our current chain, they must by transitivity
-- also intersect each other.
compareAnchoredFragments ::
     forall blk. (BlockSupportsProtocol blk, HasCallStack)
  => BlockConfig blk
  -> AnchoredFragment (Header blk)
  -> AnchoredFragment (Header blk)
  -> Ordering
compareAnchoredFragments :: forall blk.
(BlockSupportsProtocol blk, HasCallStack) =>
BlockConfig blk
-> AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk)
-> Ordering
compareAnchoredFragments BlockConfig blk
cfg AnchoredFragment (Header blk)
frag1 AnchoredFragment (Header blk)
frag2 =
    Either String () -> Ordering -> Ordering
forall a. HasCallStack => Either String () -> a -> a
assertWithMsg (AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk) -> Either String ()
forall blk.
GetHeader blk =>
AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk) -> Either String ()
precondition AnchoredFragment (Header blk)
frag1 AnchoredFragment (Header blk)
frag2) (Ordering -> Ordering) -> Ordering -> Ordering
forall a b. (a -> b) -> a -> b
$
    case (AnchoredFragment (Header blk)
frag1, AnchoredFragment (Header blk)
frag2) of
      (Empty Anchor (Header blk)
_, Empty Anchor (Header blk)
_) ->
        -- The fragments intersect but are equal: their anchors must be equal,
        -- and hence the fragments represent the same chain. They are therefore
        -- equally preferable.
        Ordering
EQ
      (Empty Anchor (Header blk)
anchor, AnchoredFragment (Header blk)
_ :> Header blk
tip') ->
        -- Since the fragments intersect, but the first one is empty, its anchor
        -- must lie somewhere along the the second. If it is the tip, the two
        -- fragments represent the same chain and are equally preferable. If
        -- not, the second chain is a strict extension of the first and is
        -- therefore strictly preferable.
        if Header blk -> Point (Header blk)
forall block. HasHeader block => block -> Point block
blockPoint Header blk
tip' Point (Header blk) -> Point (Header blk) -> Bool
forall a. Eq a => a -> a -> Bool
== Anchor (Header blk) -> Point (Header blk)
forall block. Anchor block -> Point block
AF.anchorToPoint Anchor (Header blk)
anchor
          then Ordering
EQ
          else Ordering
LT
      (AnchoredFragment (Header blk)
_ :> Header blk
tip, Empty Anchor (Header blk)
anchor') ->
        -- This case is symmetric to the previous
        if Header blk -> Point (Header blk)
forall block. HasHeader block => block -> Point block
blockPoint Header blk
tip Point (Header blk) -> Point (Header blk) -> Bool
forall a. Eq a => a -> a -> Bool
== Anchor (Header blk) -> Point (Header blk)
forall block. Anchor block -> Point block
AF.anchorToPoint Anchor (Header blk)
anchor'
          then Ordering
EQ
          else Ordering
GT
      (AnchoredFragment (Header blk)
_ :> Header blk
tip, AnchoredFragment (Header blk)
_ :> Header blk
tip') ->
        -- Case 4
        SelectView (BlockProtocol blk)
-> SelectView (BlockProtocol blk) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare
          (BlockConfig blk -> Header blk -> SelectView (BlockProtocol blk)
forall blk.
BlockSupportsProtocol blk =>
BlockConfig blk -> Header blk -> SelectView (BlockProtocol blk)
selectView BlockConfig blk
cfg Header blk
tip)
          (BlockConfig blk -> Header blk -> SelectView (BlockProtocol blk)
forall blk.
BlockSupportsProtocol blk =>
BlockConfig blk -> Header blk -> SelectView (BlockProtocol blk)
selectView BlockConfig blk
cfg Header blk
tip')

-- | Lift 'preferCandidate' to 'AnchoredFragment'
--
-- PRECONDITION: Either both fragments are non-empty or they intersect.
--
-- Usage note: the primary user of this function is the chain database. It
-- establishes the precondition when comparing a candidate fragment to our
-- current chain in the following way: The fragment is guaranteed (by the chain
-- sync client) to intersect with our chain (indeed, within at most @k@ blocks
-- from our tip, although the exact distance does not matter for
-- 'compareAnchoredFragments').
preferAnchoredCandidate ::
     forall blk. (BlockSupportsProtocol blk, HasCallStack)
  => BlockConfig blk
  -> AnchoredFragment (Header blk)      -- ^ Our chain
  -> AnchoredFragment (Header blk)      -- ^ Candidate
  -> Bool
preferAnchoredCandidate :: forall blk.
(BlockSupportsProtocol blk, HasCallStack) =>
BlockConfig blk
-> AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk)
-> Bool
preferAnchoredCandidate BlockConfig blk
cfg AnchoredFragment (Header blk)
ours AnchoredFragment (Header blk)
cand =
    Either String () -> Bool -> Bool
forall a. HasCallStack => Either String () -> a -> a
assertWithMsg (AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk) -> Either String ()
forall blk.
GetHeader blk =>
AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk) -> Either String ()
precondition AnchoredFragment (Header blk)
ours AnchoredFragment (Header blk)
cand) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
    case (AnchoredFragment (Header blk)
ours, AnchoredFragment (Header blk)
cand) of
      (AnchoredFragment (Header blk)
_, Empty Anchor (Header blk)
_) -> Bool
False
      (Empty Anchor (Header blk)
ourAnchor, AnchoredFragment (Header blk)
_ :> Header blk
theirTip) ->
        Header blk -> Point (Header blk)
forall block. HasHeader block => block -> Point block
blockPoint Header blk
theirTip Point (Header blk) -> Point (Header blk) -> Bool
forall a. Eq a => a -> a -> Bool
/= Anchor (Header blk) -> Point (Header blk)
forall block. Anchor block -> Point block
AF.anchorToPoint Anchor (Header blk)
ourAnchor
      (AnchoredFragment (Header blk)
_ :> Header blk
ourTip, AnchoredFragment (Header blk)
_ :> Header blk
theirTip) ->
        ChainOrderConfig (SelectView (BlockProtocol blk))
-> SelectView (BlockProtocol blk)
-> SelectView (BlockProtocol blk)
-> Bool
forall sv. ChainOrder sv => ChainOrderConfig sv -> sv -> sv -> Bool
preferCandidate
          (BlockConfig blk
-> ChainOrderConfig (SelectView (BlockProtocol blk))
forall blk.
BlockSupportsProtocol blk =>
BlockConfig blk
-> ChainOrderConfig (SelectView (BlockProtocol blk))
projectChainOrderConfig BlockConfig blk
cfg)
          (BlockConfig blk -> Header blk -> SelectView (BlockProtocol blk)
forall blk.
BlockSupportsProtocol blk =>
BlockConfig blk -> Header blk -> SelectView (BlockProtocol blk)
selectView BlockConfig blk
cfg Header blk
ourTip)
          (BlockConfig blk -> Header blk -> SelectView (BlockProtocol blk)
forall blk.
BlockSupportsProtocol blk =>
BlockConfig blk -> Header blk -> SelectView (BlockProtocol blk)
selectView BlockConfig blk
cfg Header blk
theirTip)

-- For 'compareAnchoredFragment' and 'preferAnchoredCandidate'.
precondition ::
     GetHeader blk
  => AnchoredFragment (Header blk)
  -> AnchoredFragment (Header blk)
  -> Either String ()
precondition :: forall blk.
GetHeader blk =>
AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk) -> Either String ()
precondition AnchoredFragment (Header blk)
frag1 AnchoredFragment (Header blk)
frag2
  | Bool -> Bool
not (AnchoredFragment (Header blk) -> Bool
forall v a b. AnchoredSeq v a b -> Bool
AF.null AnchoredFragment (Header blk)
frag1), Bool -> Bool
not (AnchoredFragment (Header blk) -> Bool
forall v a b. AnchoredSeq v a b -> Bool
AF.null AnchoredFragment (Header blk)
frag2)
  = () -> Either String ()
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Maybe (Point (Header blk)) -> Bool
forall a. Maybe a -> Bool
isJust (AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk) -> Maybe (Point (Header blk))
forall block1 block2.
(HasHeader block1, HasHeader block2,
 HeaderHash block1 ~ HeaderHash block2) =>
AnchoredFragment block1
-> AnchoredFragment block2 -> Maybe (Point block1)
AF.intersectionPoint AnchoredFragment (Header blk)
frag1 AnchoredFragment (Header blk)
frag2)
  = () -> Either String ()
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise
  = String -> Either String ()
forall a. String -> Either String a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
      String
"precondition violated: fragments should both be non-empty or they \
      \should intersect"

-- | If the two fragments `c1` and `c2` intersect, return the intersection
-- point and join the prefix of `c1` before the intersection with the suffix
-- of `c2` after the intersection. The resulting fragment has the same
-- anchor as `c1` and the same head as `c2`.
cross ::
     HasHeader block
  => AnchoredFragment block
  -> AnchoredFragment block
  -> Maybe (Point block, AnchoredFragment block)
cross :: forall block.
HasHeader block =>
AnchoredFragment block
-> AnchoredFragment block
-> Maybe (Point block, AnchoredFragment block)
cross AnchoredFragment block
c1 AnchoredFragment block
c2 = do
    (p1, _p2, _s1, s2) <- AnchoredFragment block
-> AnchoredFragment block
-> Maybe
     (AnchoredFragment block, AnchoredFragment block,
      AnchoredFragment block, AnchoredFragment block)
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 AnchoredFragment block
c1 AnchoredFragment block
c2
    -- Note that the head of `p1` and `_p2` is the intersection point, and
    -- `_s1` and `s2` are anchored in the intersection point.
    let crossed = case AnchoredFragment block
-> AnchoredFragment block -> Maybe (AnchoredFragment block)
forall block.
HasHeader block =>
AnchoredFragment block
-> AnchoredFragment block -> Maybe (AnchoredFragment block)
AF.join AnchoredFragment block
p1 AnchoredFragment block
s2 of
          Just AnchoredFragment block
c  -> AnchoredFragment block
c
          Maybe (AnchoredFragment block)
Nothing -> String -> AnchoredFragment block
forall a. HasCallStack => String -> a
error String
"invariant violation of AF.intersect"
    pure (AF.anchorPoint s2, crossed)

-- | Strip the common prefix of multiple fragments.
--
-- PRECONDITION: all fragments have the given anchor as their anchor.
stripCommonPrefix ::
     forall f blk.
     (Functor f, Foldable f, HasHeader blk) -- TODO: this uses the lazy 'map' for 'Map'...
  => AF.Anchor blk
  -> f (AnchoredFragment blk)
  -> (AnchoredFragment blk, f (AnchoredFragment blk))
stripCommonPrefix :: forall (f :: * -> *) blk.
(Functor f, Foldable f, HasHeader blk) =>
Anchor blk
-> f (AnchoredFragment blk)
-> (AnchoredFragment blk, f (AnchoredFragment blk))
stripCommonPrefix Anchor blk
sharedAnchor f (AnchoredFragment blk)
frags
  | (AnchoredFragment blk -> Bool) -> f (AnchoredFragment blk) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((Anchor blk
sharedAnchor Anchor blk -> Anchor blk -> Bool
forall a. Eq a => a -> a -> Bool
==) (Anchor blk -> Bool)
-> (AnchoredFragment blk -> Anchor blk)
-> AnchoredFragment blk
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredFragment blk -> Anchor blk
forall v a b. AnchoredSeq v a b -> a
AF.anchor) f (AnchoredFragment blk)
frags
  = (AnchoredFragment blk
commonPrefix, AnchoredFragment blk -> AnchoredFragment blk
forall {block1}.
(HeaderHash block1 ~ HeaderHash blk, HasHeader block1) =>
AnchoredFragment block1 -> AnchoredFragment block1
splitAfterCommonPrefix (AnchoredFragment blk -> AnchoredFragment blk)
-> f (AnchoredFragment blk) -> f (AnchoredFragment blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (AnchoredFragment blk)
frags)
  | Bool
otherwise
  = String -> (AnchoredFragment blk, f (AnchoredFragment blk))
forall a. HasCallStack => String -> a
error String
"Not all fragments are anchored in the given anchor"
  where
    -- Return the common prefix of two fragments with the same anchor
    -- 'sharedAnchor'.
    computeCommonPrefix ::
         AnchoredFragment blk
      -> AnchoredFragment blk
      -> AnchoredFragment blk
    computeCommonPrefix :: AnchoredFragment blk
-> AnchoredFragment blk -> AnchoredFragment blk
computeCommonPrefix AnchoredFragment blk
frag1 AnchoredFragment blk
frag2 = case 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 AnchoredFragment blk
frag1 AnchoredFragment blk
frag2 of
      Just (AnchoredFragment blk
cp, AnchoredFragment blk
_, AnchoredFragment blk
_, AnchoredFragment blk
_) -> AnchoredFragment blk
cp
      Maybe
  (AnchoredFragment blk, AnchoredFragment blk, AnchoredFragment blk,
   AnchoredFragment blk)
Nothing            -> String -> AnchoredFragment blk
forall a. HasCallStack => String -> a
error String
"unreachable"

    commonPrefix :: AnchoredFragment blk
commonPrefix
      | f (AnchoredFragment blk) -> Bool
forall a. f a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null f (AnchoredFragment blk)
frags = Anchor blk -> AnchoredFragment blk
forall v a b. Anchorable v a b => a -> AnchoredSeq v a b
AF.Empty Anchor blk
sharedAnchor
      -- TODO use Foldable1 once all our GHCs support it
      | Bool
otherwise = (AnchoredFragment blk
 -> AnchoredFragment blk -> AnchoredFragment blk)
-> [AnchoredFragment blk] -> AnchoredFragment blk
forall a. HasCallStack => (a -> a -> a) -> [a] -> a
L.foldl1' AnchoredFragment blk
-> AnchoredFragment blk -> AnchoredFragment blk
computeCommonPrefix (f (AnchoredFragment blk) -> [AnchoredFragment blk]
forall a. f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList f (AnchoredFragment blk)
frags)

    splitAfterCommonPrefix :: AnchoredFragment block1 -> AnchoredFragment block1
splitAfterCommonPrefix AnchoredFragment block1
frag =
      case AnchoredFragment block1
-> Point blk
-> Maybe (AnchoredFragment block1, AnchoredFragment block1)
forall block1 block2.
(HasHeader block1, HeaderHash block1 ~ HeaderHash block2) =>
AnchoredFragment block1
-> Point block2
-> Maybe (AnchoredFragment block1, AnchoredFragment block1)
AF.splitAfterPoint AnchoredFragment block1
frag (AnchoredFragment blk -> Point blk
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.headPoint AnchoredFragment blk
commonPrefix) of
        Just (AnchoredFragment block1
_, AnchoredFragment block1
afterCommonPrefix) -> AnchoredFragment block1
afterCommonPrefix
        Maybe (AnchoredFragment block1, AnchoredFragment block1)
Nothing                     -> String -> AnchoredFragment block1
forall a. HasCallStack => String -> a
error String
"unreachable"