{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}

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

import           Control.Monad.Except (throwError)
import           Data.Function (on)
import           Data.Maybe (isJust)
import           Data.Word (Word64)
import           GHC.Stack

import           Ouroboros.Network.AnchoredFragment (AnchoredFragment,
                     AnchoredSeq (Empty, (:>)))
import qualified Ouroboros.Network.AnchoredFragment as AF

import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Util.Assert

{-------------------------------------------------------------------------------
  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 :: 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 :: 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

-- | Lift 'compareChains' to 'AnchoredFragment'
--
-- 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. It
-- establishes the precondition in two different ways:
--
-- * When comparing a candidate fragment to our current chain, the fragment is
--   guaranteed (by the chain sync client) to intersect with our chain (indeed,
--   within at  most @k@ blocks from our tp, although the exact distance does
--   not matter for 'compareAnchoredCandidates').
-- * 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 :: 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 Either String ()
precondition (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')
  where
    precondition :: Either String ()
    precondition :: Either String ()
precondition
      | 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 (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 (m :: * -> *) a. Monad m => a -> m a
return ()
      | Bool
otherwise
      = String -> Either String ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
          String
"precondition violated: fragments both empty or don't intersect"

-- | Lift 'preferCandidate' to 'AnchoredFragment'
--
-- See discussion for 'compareAnchoredCandidates'.
preferAnchoredCandidate ::
     forall blk. (BlockSupportsProtocol blk, HasCallStack)
  => BlockConfig blk
  -> AnchoredFragment (Header blk)      -- ^ Our chain
  -> AnchoredFragment (Header blk)      -- ^ Candidate
  -> Bool
preferAnchoredCandidate :: BlockConfig blk
-> AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk)
-> Bool
preferAnchoredCandidate BlockConfig blk
cfg AnchoredFragment (Header blk)
ours AnchoredFragment (Header blk)
cand =
    BlockConfig blk
-> AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk)
-> Ordering
forall blk.
(BlockSupportsProtocol blk, HasCallStack) =>
BlockConfig blk
-> AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk)
-> Ordering
compareAnchoredFragments BlockConfig blk
cfg AnchoredFragment (Header blk)
ours AnchoredFragment (Header blk)
cand Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
LT