{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Ouroboros.Consensus.Util.AnchoredFragment (
compareAnchoredFragments
, compareHeadBlockNo
, cross
, forksAtMostKBlocks
, preferAnchoredCandidate
, stripCommonPrefix
) where
import Control.Monad.Except (throwError)
import Data.Foldable (toList)
import qualified Data.Foldable1 as F1
import Data.Function (on)
import qualified Data.List.NonEmpty as NE
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
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
-> AnchoredFragment b
-> AnchoredFragment b
-> Bool
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
compareAnchoredFragments ::
forall blk h.
( BlockSupportsProtocol blk
, HasCallStack
, GetHeader1 h
, HasHeader (h blk)
)
=> BlockConfig blk
-> AnchoredFragment (h blk)
-> AnchoredFragment (h blk)
-> Ordering
compareAnchoredFragments :: forall blk (h :: * -> *).
(BlockSupportsProtocol blk, HasCallStack, GetHeader1 h,
HasHeader (h blk)) =>
BlockConfig blk
-> AnchoredFragment (h blk) -> AnchoredFragment (h blk) -> Ordering
compareAnchoredFragments BlockConfig blk
cfg AnchoredFragment (h blk)
frag1 AnchoredFragment (h blk)
frag2 =
Either String () -> Ordering -> Ordering
forall a. HasCallStack => Either String () -> a -> a
assertWithMsg (AnchoredFragment (h blk)
-> AnchoredFragment (h blk) -> Either String ()
forall (h :: * -> *) blk (h' :: * -> *).
(HeaderHash (h blk) ~ HeaderHash (h' blk), HasHeader (h blk),
HasHeader (h' blk)) =>
AnchoredFragment (h blk)
-> AnchoredFragment (h' blk) -> Either String ()
precondition AnchoredFragment (h blk)
frag1 AnchoredFragment (h blk)
frag2) (Ordering -> Ordering) -> Ordering -> Ordering
forall a b. (a -> b) -> a -> b
$
case (AnchoredFragment (h blk)
frag1, AnchoredFragment (h blk)
frag2) of
(Empty Anchor (h blk)
_, Empty Anchor (h blk)
_) ->
Ordering
EQ
(Empty Anchor (h blk)
anchor, AnchoredFragment (h blk)
_ :> h blk
tip') ->
if h blk -> Point (h blk)
forall block. HasHeader block => block -> Point block
blockPoint h blk
tip' Point (h blk) -> Point (h blk) -> Bool
forall a. Eq a => a -> a -> Bool
== Point (h blk) -> Point (h blk)
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
AF.castPoint (Anchor (h blk) -> Point (h blk)
forall block. Anchor block -> Point block
AF.anchorToPoint Anchor (h blk)
anchor)
then Ordering
EQ
else Ordering
LT
(AnchoredFragment (h blk)
_ :> h blk
tip, Empty Anchor (h blk)
anchor') ->
if h blk -> Point (h blk)
forall block. HasHeader block => block -> Point block
blockPoint h blk
tip Point (h blk) -> Point (h blk) -> Bool
forall a. Eq a => a -> a -> Bool
== Point (h blk) -> Point (h blk)
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
AF.castPoint (Anchor (h blk) -> Point (h blk)
forall block. Anchor block -> Point block
AF.anchorToPoint Anchor (h blk)
anchor')
then Ordering
EQ
else Ordering
GT
(AnchoredFragment (h blk)
_ :> h blk
tip, AnchoredFragment (h blk)
_ :> h blk
tip') ->
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 (h blk -> Header blk
forall blk. h blk -> Header blk
forall (t :: * -> *) blk. GetHeader1 t => t blk -> Header blk
getHeader1 h blk
tip ))
(BlockConfig blk -> Header blk -> SelectView (BlockProtocol blk)
forall blk.
BlockSupportsProtocol blk =>
BlockConfig blk -> Header blk -> SelectView (BlockProtocol blk)
selectView BlockConfig blk
cfg (h blk -> Header blk
forall blk. h blk -> Header blk
forall (t :: * -> *) blk. GetHeader1 t => t blk -> Header blk
getHeader1 h blk
tip'))
preferAnchoredCandidate ::
forall blk h h'.
( BlockSupportsProtocol blk
, HasCallStack
, GetHeader1 h
, GetHeader1 h'
, HeaderHash (h blk) ~ HeaderHash (h' blk)
, HasHeader (h blk)
, HasHeader (h' blk)
)
=> BlockConfig blk
-> AnchoredFragment (h blk)
-> AnchoredFragment (h' blk)
-> Bool
preferAnchoredCandidate :: forall blk (h :: * -> *) (h' :: * -> *).
(BlockSupportsProtocol blk, HasCallStack, GetHeader1 h,
GetHeader1 h', HeaderHash (h blk) ~ HeaderHash (h' blk),
HasHeader (h blk), HasHeader (h' blk)) =>
BlockConfig blk
-> AnchoredFragment (h blk) -> AnchoredFragment (h' blk) -> Bool
preferAnchoredCandidate BlockConfig blk
cfg AnchoredFragment (h blk)
ours AnchoredFragment (h' blk)
cand =
Either String () -> Bool -> Bool
forall a. HasCallStack => Either String () -> a -> a
assertWithMsg (AnchoredFragment (h blk)
-> AnchoredFragment (h' blk) -> Either String ()
forall (h :: * -> *) blk (h' :: * -> *).
(HeaderHash (h blk) ~ HeaderHash (h' blk), HasHeader (h blk),
HasHeader (h' blk)) =>
AnchoredFragment (h blk)
-> AnchoredFragment (h' blk) -> Either String ()
precondition AnchoredFragment (h blk)
ours AnchoredFragment (h' blk)
cand) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
case (AnchoredFragment (h blk)
ours, AnchoredFragment (h' blk)
cand) of
(AnchoredFragment (h blk)
_, Empty Anchor (h' blk)
_) -> Bool
False
(Empty Anchor (h blk)
ourAnchor, AnchoredFragment (h' blk)
_ :> h' blk
theirTip) ->
h' blk -> Point (h' blk)
forall block. HasHeader block => block -> Point block
blockPoint h' blk
theirTip Point (h' blk) -> Point (h' blk) -> Bool
forall a. Eq a => a -> a -> Bool
/= Point (h blk) -> Point (h' blk)
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Anchor (h blk) -> Point (h blk)
forall block. Anchor block -> Point block
AF.anchorToPoint Anchor (h blk)
ourAnchor)
(AnchoredFragment (h blk)
_ :> h blk
ourTip, AnchoredFragment (h' blk)
_ :> h' 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 (h blk -> Header blk
forall blk. h blk -> Header blk
forall (t :: * -> *) blk. GetHeader1 t => t blk -> Header blk
getHeader1 h blk
ourTip))
(BlockConfig blk -> Header blk -> SelectView (BlockProtocol blk)
forall blk.
BlockSupportsProtocol blk =>
BlockConfig blk -> Header blk -> SelectView (BlockProtocol blk)
selectView BlockConfig blk
cfg (h' blk -> Header blk
forall blk. h' blk -> Header blk
forall (t :: * -> *) blk. GetHeader1 t => t blk -> Header blk
getHeader1 h' blk
theirTip))
precondition ::
( HeaderHash (h blk) ~ HeaderHash (h' blk)
, HasHeader (h blk)
, HasHeader (h' blk)
)
=> AnchoredFragment (h blk)
-> AnchoredFragment (h' blk)
-> Either String ()
precondition :: forall (h :: * -> *) blk (h' :: * -> *).
(HeaderHash (h blk) ~ HeaderHash (h' blk), HasHeader (h blk),
HasHeader (h' blk)) =>
AnchoredFragment (h blk)
-> AnchoredFragment (h' blk) -> Either String ()
precondition AnchoredFragment (h blk)
frag1 AnchoredFragment (h' blk)
frag2
| Bool -> Bool
not (AnchoredFragment (h blk) -> Bool
forall v a b. AnchoredSeq v a b -> Bool
AF.null AnchoredFragment (h blk)
frag1), Bool -> Bool
not (AnchoredFragment (h' blk) -> Bool
forall v a b. AnchoredSeq v a b -> Bool
AF.null AnchoredFragment (h' blk)
frag2)
= () -> Either String ()
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Maybe (Point (h blk)) -> Bool
forall a. Maybe a -> Bool
isJust (AnchoredFragment (h blk)
-> AnchoredFragment (h' blk) -> Maybe (Point (h blk))
forall block1 block2.
(HasHeader block1, HasHeader block2,
HeaderHash block1 ~ HeaderHash block2) =>
AnchoredFragment block1
-> AnchoredFragment block2 -> Maybe (Point block1)
AF.intersectionPoint AnchoredFragment (h blk)
frag1 AnchoredFragment (h' 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"
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
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)
stripCommonPrefix ::
forall f blk.
(Functor f, Foldable f, HasHeader blk)
=> 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
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
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 = case [AnchoredFragment blk] -> Maybe (NonEmpty (AnchoredFragment blk))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty ([AnchoredFragment blk] -> Maybe (NonEmpty (AnchoredFragment blk)))
-> [AnchoredFragment blk]
-> Maybe (NonEmpty (AnchoredFragment blk))
forall a b. (a -> b) -> a -> b
$ f (AnchoredFragment blk) -> [AnchoredFragment blk]
forall a. f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList f (AnchoredFragment blk)
frags of
Maybe (NonEmpty (AnchoredFragment blk))
Nothing -> Anchor blk -> AnchoredFragment blk
forall v a b. Anchorable v a b => a -> AnchoredSeq v a b
AF.Empty Anchor blk
sharedAnchor
Just NonEmpty (AnchoredFragment blk)
fragsNE -> (AnchoredFragment blk
-> AnchoredFragment blk -> AnchoredFragment blk)
-> NonEmpty (AnchoredFragment blk) -> AnchoredFragment blk
forall (t :: * -> *) a. Foldable1 t => (a -> a -> a) -> t a -> a
F1.foldl1' AnchoredFragment blk
-> AnchoredFragment blk -> AnchoredFragment blk
computeCommonPrefix NonEmpty (AnchoredFragment blk)
fragsNE
splitAfterCommonPrefix :: AnchoredFragment blk -> AnchoredFragment blk
splitAfterCommonPrefix AnchoredFragment blk
frag =
case 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
frag (AnchoredFragment blk -> Point blk
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.headPoint AnchoredFragment blk
commonPrefix) of
Just (AnchoredFragment blk
_, AnchoredFragment blk
afterCommonPrefix) -> AnchoredFragment blk
afterCommonPrefix
Maybe (AnchoredFragment blk, AnchoredFragment blk)
Nothing -> String -> AnchoredFragment blk
forall a. HasCallStack => String -> a
error String
"unreachable"