{-# LANGUAGE DeriveFunctor       #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- Just to keep 'HasCallstack' on 'validExtension'.
{-# OPTIONS_GHC -Wno-redundant-constraints #-}

-- | Reference implementation of a representation of a block chain
--
module Ouroboros.Network.Mock.Chain
  ( -- * Chain type and fundamental operations
    Chain (..)
  , valid
  , validExtension
  , foldChain
  , chainToList
    -- ** Block re-exports
  , HasHeader (..)
  , HeaderHash
    -- * Point type
  , Point (..)
  , blockPoint
    -- * Chain construction and inspection
    -- ** Genesis
  , genesis
    -- ** Head inspection
  , headPoint
  , headSlot
  , headHash
  , headTip
  , headBlockNo
  , headAnchor
    -- ** Basic operations
  , head
  , toNewestFirst
  , toOldestFirst
  , fromNewestFirst
  , fromOldestFirst
  , drop
  , length
  , null
  , takeWhile
    -- ** Update type and operations
  , ChainUpdate (..)
  , addBlock
  , rollback
  , applyChainUpdate
  , applyChainUpdates
    -- * Special operations
  , pointOnChain
  , pointIsAfter
  , successorBlock
  , selectChain
  , selectPoints
  , findBlock
  , selectBlockRange
  , findFirstPoint
  , intersectChains
  , isPrefixOf
    -- * Conversion to/from AnchoredFragment
  , fromAnchoredFragment
  , toAnchoredFragment
    -- * Helper functions
  , prettyPrintChain
  ) where

import Prelude hiding (drop, head, length, null, takeWhile)
import Prelude qualified

import Codec.CBOR.Decoding (decodeListLen)
import Codec.CBOR.Encoding (encodeListLen)
import Codec.Serialise (Serialise (..))
import Control.Exception (assert)
import Data.List qualified as L
import GHC.Stack

import Ouroboros.Network.AnchoredFragment (Anchor (..))
import Ouroboros.Network.AnchoredFragment qualified as AF
import Ouroboros.Network.Block
import Ouroboros.Network.Point (WithOrigin (..))

--
-- Blockchain type
--

data Chain block = Genesis | Chain block :> block
  deriving (Chain block -> Chain block -> Bool
(Chain block -> Chain block -> Bool)
-> (Chain block -> Chain block -> Bool) -> Eq (Chain block)
forall block. Eq block => Chain block -> Chain block -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall block. Eq block => Chain block -> Chain block -> Bool
== :: Chain block -> Chain block -> Bool
$c/= :: forall block. Eq block => Chain block -> Chain block -> Bool
/= :: Chain block -> Chain block -> Bool
Eq, Eq (Chain block)
Eq (Chain block) =>
(Chain block -> Chain block -> Ordering)
-> (Chain block -> Chain block -> Bool)
-> (Chain block -> Chain block -> Bool)
-> (Chain block -> Chain block -> Bool)
-> (Chain block -> Chain block -> Bool)
-> (Chain block -> Chain block -> Chain block)
-> (Chain block -> Chain block -> Chain block)
-> Ord (Chain block)
Chain block -> Chain block -> Bool
Chain block -> Chain block -> Ordering
Chain block -> Chain block -> Chain block
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall block. Ord block => Eq (Chain block)
forall block. Ord block => Chain block -> Chain block -> Bool
forall block. Ord block => Chain block -> Chain block -> Ordering
forall block.
Ord block =>
Chain block -> Chain block -> Chain block
$ccompare :: forall block. Ord block => Chain block -> Chain block -> Ordering
compare :: Chain block -> Chain block -> Ordering
$c< :: forall block. Ord block => Chain block -> Chain block -> Bool
< :: Chain block -> Chain block -> Bool
$c<= :: forall block. Ord block => Chain block -> Chain block -> Bool
<= :: Chain block -> Chain block -> Bool
$c> :: forall block. Ord block => Chain block -> Chain block -> Bool
> :: Chain block -> Chain block -> Bool
$c>= :: forall block. Ord block => Chain block -> Chain block -> Bool
>= :: Chain block -> Chain block -> Bool
$cmax :: forall block.
Ord block =>
Chain block -> Chain block -> Chain block
max :: Chain block -> Chain block -> Chain block
$cmin :: forall block.
Ord block =>
Chain block -> Chain block -> Chain block
min :: Chain block -> Chain block -> Chain block
Ord, Int -> Chain block -> ShowS
[Chain block] -> ShowS
Chain block -> String
(Int -> Chain block -> ShowS)
-> (Chain block -> String)
-> ([Chain block] -> ShowS)
-> Show (Chain block)
forall block. Show block => Int -> Chain block -> ShowS
forall block. Show block => [Chain block] -> ShowS
forall block. Show block => Chain block -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall block. Show block => Int -> Chain block -> ShowS
showsPrec :: Int -> Chain block -> ShowS
$cshow :: forall block. Show block => Chain block -> String
show :: Chain block -> String
$cshowList :: forall block. Show block => [Chain block] -> ShowS
showList :: [Chain block] -> ShowS
Show, (forall a b. (a -> b) -> Chain a -> Chain b)
-> (forall a b. a -> Chain b -> Chain a) -> Functor Chain
forall a b. a -> Chain b -> Chain a
forall a b. (a -> b) -> Chain a -> Chain b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Chain a -> Chain b
fmap :: forall a b. (a -> b) -> Chain a -> Chain b
$c<$ :: forall a b. a -> Chain b -> Chain a
<$ :: forall a b. a -> Chain b -> Chain a
Functor)

infixl 5 :>

takeWhile :: (blk -> Bool) -> Chain blk -> Chain blk
takeWhile :: forall blk. (blk -> Bool) -> Chain blk -> Chain blk
takeWhile blk -> Bool
p Chain blk
c = Chain blk -> [blk] -> Chain blk
go Chain blk
forall block. Chain block
Genesis (Chain blk -> [blk]
forall block. Chain block -> [block]
toOldestFirst Chain blk
c)
  where
    go :: Chain blk -> [blk] -> Chain blk
go Chain blk
acc [] = Chain blk
acc
    go Chain blk
acc (blk
b : [blk]
bs) =
      if blk -> Bool
p blk
b
      then Chain blk -> [blk] -> Chain blk
go (Chain blk
acc Chain blk -> blk -> Chain blk
forall block. Chain block -> block -> Chain block
:> blk
b) [blk]
bs
      else Chain blk
acc

foldChain :: (a -> b -> a) -> a -> Chain b -> a
foldChain :: forall a b. (a -> b -> a) -> a -> Chain b -> a
foldChain a -> b -> a
_blk a
gen Chain b
Genesis  = a
gen
foldChain  a -> b -> a
blk a
gen (Chain b
c :> b
b) = a -> b -> a
blk ((a -> b -> a) -> a -> Chain b -> a
forall a b. (a -> b -> a) -> a -> Chain b -> a
foldChain a -> b -> a
blk a
gen Chain b
c) b
b

-- | Make a list from a 'Chain', in newest-to-oldest order.
chainToList :: Chain block -> [block]
chainToList :: forall block. Chain block -> [block]
chainToList = ([block] -> block -> [block]) -> [block] -> Chain block -> [block]
forall a b. (a -> b -> a) -> a -> Chain b -> a
foldChain ((block -> [block] -> [block]) -> [block] -> block -> [block]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (:)) []

prettyPrintChain :: String -> (block -> String) -> Chain block -> String
prettyPrintChain :: forall block. String -> (block -> String) -> Chain block -> String
prettyPrintChain String
nl block -> String
ppBlock = (String -> block -> String) -> String -> Chain block -> String
forall a b. (a -> b -> a) -> a -> Chain b -> a
foldChain (\String
s block
b -> String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
nl String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"    " String -> ShowS
forall a. [a] -> [a] -> [a]
++ block -> String
ppBlock block
b) String
"Genesis"

genesis :: Chain b
genesis :: forall block. Chain block
genesis = Chain b
forall block. Chain block
Genesis

valid :: HasFullHeader block => Chain block -> Bool
valid :: forall block. HasFullHeader block => Chain block -> Bool
valid Chain block
Genesis  = Bool
True
valid (Chain block
c :> block
b) = Chain block -> Bool
forall block. HasFullHeader block => Chain block -> Bool
valid Chain block
c Bool -> Bool -> Bool
&& Chain block -> block -> Bool
forall block.
(HasCallStack, HasFullHeader block) =>
Chain block -> block -> Bool
validExtension Chain block
c block
b

validExtension
  :: (HasCallStack, HasFullHeader block)
  => Chain block -> block -> Bool
validExtension :: forall block.
(HasCallStack, HasFullHeader block) =>
Chain block -> block -> Bool
validExtension Chain block
c block
b = block -> Bool
forall b. HasFullHeader b => b -> Bool
blockInvariant block
b
                  Bool -> Bool -> Bool
&& Chain block -> ChainHash block
forall block. HasHeader block => Chain block -> ChainHash block
headHash Chain block
c ChainHash block -> ChainHash block -> Bool
forall a. Eq a => a -> a -> Bool
== block -> ChainHash block
forall b. HasFullHeader b => b -> ChainHash b
blockPrevHash block
b
                  -- The Ord instance for WithOrigin puts At _ after Origin.
                  -- An EBB has the same SlotNo as the block after it, hence
                  -- the loose inequality.
                  Bool -> Bool -> Bool
&& Chain block -> WithOrigin SlotNo
forall block. HasHeader block => Chain block -> WithOrigin SlotNo
headSlot Chain block
c WithOrigin SlotNo -> WithOrigin SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
<= SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
At (block -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot block
b)
                  -- The block number must be non-strictly increasing. An EBB
                  -- has the same block number as its parent. It can increase
                  -- by at most one.
                  Bool -> Bool -> Bool
&& case Chain block -> WithOrigin BlockNo
forall block. HasHeader block => Chain block -> WithOrigin BlockNo
headBlockNo Chain block
c of
                       WithOrigin BlockNo
Origin    -> block -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo block
b BlockNo -> BlockNo -> Bool
forall a. Eq a => a -> a -> Bool
== BlockNo
0
                       At BlockNo
prevNo -> block -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo block
b BlockNo -> BlockNo -> Bool
forall a. Eq a => a -> a -> Bool
== BlockNo -> BlockNo
forall a. Enum a => a -> a
succ BlockNo
prevNo Bool -> Bool -> Bool
|| block -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo block
b BlockNo -> BlockNo -> Bool
forall a. Eq a => a -> a -> Bool
== BlockNo
prevNo

head :: Chain b -> Maybe b
head :: forall b. Chain b -> Maybe b
head Chain b
Genesis  = Maybe b
forall a. Maybe a
Nothing
head (Chain b
_ :> b
b) = b -> Maybe b
forall a. a -> Maybe a
Just b
b

headPoint :: HasHeader block => Chain block -> Point block
headPoint :: forall block. HasHeader block => Chain block -> Point block
headPoint Chain block
Genesis  = Point block
forall {k} (block :: k). Point block
genesisPoint
headPoint (Chain block
_ :> block
b) = block -> Point block
forall block. HasHeader block => block -> Point block
blockPoint block
b

headSlot :: HasHeader block => Chain block -> WithOrigin SlotNo
headSlot :: forall block. HasHeader block => Chain block -> WithOrigin SlotNo
headSlot = Point block -> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot (Point block -> WithOrigin SlotNo)
-> (Chain block -> Point block) -> Chain block -> WithOrigin SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Chain block -> Point block
forall block. HasHeader block => Chain block -> Point block
headPoint

headHash :: HasHeader block => Chain block -> ChainHash block
headHash :: forall block. HasHeader block => Chain block -> ChainHash block
headHash = Point block -> ChainHash block
forall {k} (block :: k). Point block -> ChainHash block
pointHash (Point block -> ChainHash block)
-> (Chain block -> Point block) -> Chain block -> ChainHash block
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Chain block -> Point block
forall block. HasHeader block => Chain block -> Point block
headPoint

headTip :: HasHeader block => Chain block -> Tip block
headTip :: forall block. HasHeader block => Chain block -> Tip block
headTip Chain block
Genesis  = Tip block
forall {k} (b :: k). Tip b
TipGenesis
headTip (Chain block
_ :> block
b) = SlotNo -> HeaderHash block -> BlockNo -> Tip block
forall {k} (b :: k). SlotNo -> HeaderHash b -> BlockNo -> Tip b
Tip (block -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot block
b) (block -> HeaderHash block
forall b. HasHeader b => b -> HeaderHash b
blockHash block
b) (block -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo block
b)

headAnchor :: HasHeader block => Chain block -> Anchor block
headAnchor :: forall block. HasHeader block => Chain block -> Anchor block
headAnchor Chain block
Genesis  = Anchor block
forall block. Anchor block
AnchorGenesis
headAnchor (Chain block
_ :> block
b) = block -> Anchor block
forall block. HasHeader block => block -> Anchor block
AF.anchorFromBlock block
b

headBlockNo :: HasHeader block => Chain block -> WithOrigin BlockNo
headBlockNo :: forall block. HasHeader block => Chain block -> WithOrigin BlockNo
headBlockNo Chain block
Genesis  = WithOrigin BlockNo
forall t. WithOrigin t
Origin
headBlockNo (Chain block
_ :> block
b) = BlockNo -> WithOrigin BlockNo
forall t. t -> WithOrigin t
At (block -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo block
b)

-- | Produce the list of blocks, from most recent back to genesis
--
toNewestFirst :: Chain block -> [block]
toNewestFirst :: forall block. Chain block -> [block]
toNewestFirst = ([block] -> block -> [block]) -> [block] -> Chain block -> [block]
forall a b. (a -> b -> a) -> a -> Chain b -> a
foldChain ((block -> [block] -> [block]) -> [block] -> block -> [block]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (:)) []

-- | Produce the list of blocks, from genesis to the most recent
toOldestFirst :: Chain block -> [block]
toOldestFirst :: forall block. Chain block -> [block]
toOldestFirst = [block] -> [block]
forall a. [a] -> [a]
reverse ([block] -> [block])
-> (Chain block -> [block]) -> Chain block -> [block]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Chain block -> [block]
forall block. Chain block -> [block]
toNewestFirst

-- | Make a chain from a list of blocks. The head of the list is the head
-- of the chain.
--
fromNewestFirst :: HasHeader block => [block] -> Chain block
fromNewestFirst :: forall block. HasHeader block => [block] -> Chain block
fromNewestFirst [block]
bs = (block -> Chain block -> Chain block)
-> Chain block -> [block] -> Chain block
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Chain block -> block -> Chain block)
-> block -> Chain block -> Chain block
forall a b c. (a -> b -> c) -> b -> a -> c
flip Chain block -> block -> Chain block
forall block. Chain block -> block -> Chain block
(:>)) Chain block
forall block. Chain block
Genesis [block]
bs

-- | Construct chain from list of blocks from oldest to newest
fromOldestFirst :: HasHeader block => [block] -> Chain block
fromOldestFirst :: forall block. HasHeader block => [block] -> Chain block
fromOldestFirst [block]
bs = (Chain block -> block -> Chain block)
-> Chain block -> [block] -> Chain block
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl' Chain block -> block -> Chain block
forall block. Chain block -> block -> Chain block
(:>) Chain block
forall block. Chain block
Genesis [block]
bs

drop :: Int -> Chain block -> Chain block
drop :: forall block. Int -> Chain block -> Chain block
drop Int
0 Chain block
c        = Chain block
c
drop Int
_ Chain block
Genesis  = Chain block
forall block. Chain block
Genesis
drop Int
n (Chain block
c :> block
_) = Int -> Chain block -> Chain block
forall block. Int -> Chain block -> Chain block
drop (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Chain block
c

length :: Chain block -> Int
length :: forall block. Chain block -> Int
length = (Int -> block -> Int) -> Int -> Chain block -> Int
forall a b. (a -> b -> a) -> a -> Chain b -> a
foldChain (\Int
n block
_ -> Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
0

null :: Chain block -> Bool
null :: forall block. Chain block -> Bool
null Chain block
Genesis = Bool
True
null Chain block
_       = Bool
False

addBlock :: HasHeader block => block -> Chain block -> Chain block
addBlock :: forall block.
HasHeader block =>
block -> Chain block -> Chain block
addBlock block
b Chain block
c = Chain block
c Chain block -> block -> Chain block
forall block. Chain block -> block -> Chain block
:> block
b

pointOnChain :: HasHeader block => Point block -> Chain block -> Bool
pointOnChain :: forall block. HasHeader block => Point block -> Chain block -> Bool
pointOnChain Point block
GenesisPoint               Chain block
_       = Bool
True
pointOnChain (BlockPoint SlotNo
_ HeaderHash block
_)           Chain block
Genesis = Bool
False
pointOnChain p :: Point block
p@(BlockPoint SlotNo
pslot HeaderHash block
phash) (Chain block
c :> block
b)
  | SlotNo
pslot SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
>  block -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot block
b = Bool
False
  | HeaderHash block
phash HeaderHash block -> HeaderHash block -> Bool
forall a. Eq a => a -> a -> Bool
== block -> HeaderHash block
forall b. HasHeader b => b -> HeaderHash b
blockHash block
b = Bool
True
  | Bool
otherwise            = Point block -> Chain block -> Bool
forall block. HasHeader block => Point block -> Chain block -> Bool
pointOnChain Point block
p Chain block
c

-- | Check whether the first point is after the second point on the chain.
-- Usually, this can simply be checked using the 'SlotNo's, but some blocks
-- may have the same 'SlotNo'.
--
-- When the first point equals the second point, the answer will be 'False'.
--
-- PRECONDITION: both points are on the chain.
pointIsAfter :: HasHeader block
             => Point block -> Point block -> Chain block -> Bool
pointIsAfter :: forall block.
HasHeader block =>
Point block -> Point block -> Chain block -> Bool
pointIsAfter Point block
pt1 Point block
pt2 Chain block
c =
    Bool -> Bool -> Bool
forall a. HasCallStack => Bool -> a -> a
assert (Point block -> Chain block -> Bool
forall block. HasHeader block => Point block -> Chain block -> Bool
pointOnChain Point block
pt1 Chain block
c Bool -> Bool -> Bool
&& Point block -> Chain block -> Bool
forall block. HasHeader block => Point block -> Chain block -> Bool
pointOnChain Point block
pt2 Chain block
c) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
    case Point block -> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot Point block
pt1 WithOrigin SlotNo -> WithOrigin SlotNo -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Point block -> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot Point block
pt2 of
      Ordering
LT -> Bool
False
      Ordering
GT -> Bool
True
      Ordering
EQ | Just (AnchoredFragment block
_, AnchoredFragment block
afterPt2) <- AnchoredFragment block
-> Point block
-> Maybe (AnchoredFragment block, AnchoredFragment block)
forall block1 block2.
(HasHeader block1, HeaderHash block1 ~ HeaderHash block2) =>
AnchoredFragment block1
-> Point block2
-> Maybe (AnchoredFragment block1, AnchoredFragment block1)
AF.splitAfterPoint (Chain block -> AnchoredFragment block
forall block.
HasHeader block =>
Chain block -> AnchoredFragment block
toAnchoredFragment Chain block
c) Point block
pt2
         -> Point block -> AnchoredFragment block -> Bool
forall block.
HasHeader block =>
Point block -> AnchoredFragment block -> Bool
AF.pointOnFragment Point block
pt1 AnchoredFragment block
afterPt2
         | Bool
otherwise
         -> Bool
False

rollback :: HasHeader block => Point block -> Chain block -> Maybe (Chain block)
rollback :: forall block.
HasHeader block =>
Point block -> Chain block -> Maybe (Chain block)
rollback Point block
p (Chain block
c :> block
b) | block -> Point block
forall block. HasHeader block => block -> Point block
blockPoint block
b Point block -> Point block -> Bool
forall a. Eq a => a -> a -> Bool
== Point block
p = Chain block -> Maybe (Chain block)
forall a. a -> Maybe a
Just (Chain block
c Chain block -> block -> Chain block
forall block. Chain block -> block -> Chain block
:> block
b)
                    | Bool
otherwise         = Point block -> Chain block -> Maybe (Chain block)
forall block.
HasHeader block =>
Point block -> Chain block -> Maybe (Chain block)
rollback Point block
p Chain block
c
rollback Point block
p Chain block
Genesis  | Point block
p Point block -> Point block -> Bool
forall a. Eq a => a -> a -> Bool
== Point block
forall {k} (block :: k). Point block
genesisPoint = Chain block -> Maybe (Chain block)
forall a. a -> Maybe a
Just Chain block
forall block. Chain block
Genesis
                    | Bool
otherwise         = Maybe (Chain block)
forall a. Maybe a
Nothing

-- | A 'Just' result holds the provided point's successor block. A 'Nothing'
-- result means the provided point was the tip.
--
-- The function will error if the point is not on the chain - callers can use
-- 'pointOnChain' to check point membership on a chain in advance of calling
-- this function.
successorBlock :: HasHeader block => Point block -> Chain block -> Maybe block
successorBlock :: forall block.
HasHeader block =>
Point block -> Chain block -> Maybe block
successorBlock Point block
p Chain block
c0 | Chain block -> Point block
forall block. HasHeader block => Chain block -> Point block
headPoint Chain block
c0 Point block -> Point block -> Bool
forall a. Eq a => a -> a -> Bool
== Point block
p = Maybe block
forall a. Maybe a
Nothing
successorBlock Point block
p Chain block
c0 = Chain block -> Maybe block
go Chain block
c0
  where
    go :: Chain block -> Maybe block
go (Chain block
c :> block
b' :> block
b) | block -> Point block
forall block. HasHeader block => block -> Point block
blockPoint block
b' Point block -> Point block -> Bool
forall a. Eq a => a -> a -> Bool
== Point block
p = block -> Maybe block
forall a. a -> Maybe a
Just block
b
                      | Bool
otherwise          = Chain block -> Maybe block
go (Chain block
c Chain block -> block -> Chain block
forall block. Chain block -> block -> Chain block
:> block
b')
    go (Chain block
Genesis :> block
b) | Point block
p Point block -> Point block -> Bool
forall a. Eq a => a -> a -> Bool
== Point block
forall {k} (block :: k). Point block
genesisPoint  = block -> Maybe block
forall a. a -> Maybe a
Just block
b
    go Chain block
_ = String -> Maybe block
forall a. HasCallStack => String -> a
error String
"successorBlock: point not on chain"

selectChain
  :: HasHeader block
  => Chain block
  -> Chain block
  -> Chain block
selectChain :: forall block.
HasHeader block =>
Chain block -> Chain block -> Chain block
selectChain Chain block
c1 Chain block
c2 =
  -- NB: it's not true in general that headBlockNo c = length c, since the
  -- block number is non-strictly increasing. A chain c2 can be shorter in
  -- _length_ i.e. number of blocks than c1, but still have a higher block
  -- number than c1.
  if Chain block -> WithOrigin BlockNo
forall block. HasHeader block => Chain block -> WithOrigin BlockNo
headBlockNo Chain block
c1 WithOrigin BlockNo -> WithOrigin BlockNo -> Bool
forall a. Ord a => a -> a -> Bool
>= Chain block -> WithOrigin BlockNo
forall block. HasHeader block => Chain block -> WithOrigin BlockNo
headBlockNo Chain block
c2
    then Chain block
c1
    else Chain block
c2

isPrefixOf :: Eq block => Chain block -> Chain block -> Bool
Chain block
a isPrefixOf :: forall block. Eq block => Chain block -> Chain block -> Bool
`isPrefixOf` Chain block
b = [block] -> [block]
forall a. [a] -> [a]
reverse (Chain block -> [block]
forall block. Chain block -> [block]
toNewestFirst Chain block
a) [block] -> [block] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`L.isPrefixOf` [block] -> [block]
forall a. [a] -> [a]
reverse (Chain block -> [block]
forall block. Chain block -> [block]
toNewestFirst Chain block
b)


applyChainUpdate :: HasHeader block
                 => ChainUpdate block block
                 -> Chain block
                 -> Maybe (Chain block)
applyChainUpdate :: forall block.
HasHeader block =>
ChainUpdate block block -> Chain block -> Maybe (Chain block)
applyChainUpdate (AddBlock block
b) Chain block
c = Chain block -> Maybe (Chain block)
forall a. a -> Maybe a
Just (block -> Chain block -> Chain block
forall block.
HasHeader block =>
block -> Chain block -> Chain block
addBlock block
b Chain block
c)
applyChainUpdate (RollBack Point block
p) Chain block
c =       Point block -> Chain block -> Maybe (Chain block)
forall block.
HasHeader block =>
Point block -> Chain block -> Maybe (Chain block)
rollback Point block
p Chain block
c

applyChainUpdates :: HasHeader block
                  => [ChainUpdate block block]
                  -> Chain block
                  -> Maybe (Chain block)
applyChainUpdates :: forall block.
HasHeader block =>
[ChainUpdate block block] -> Chain block -> Maybe (Chain block)
applyChainUpdates []     Chain block
c = Chain block -> Maybe (Chain block)
forall a. a -> Maybe a
Just Chain block
c
applyChainUpdates (ChainUpdate block block
u:[ChainUpdate block block]
us) Chain block
c = [ChainUpdate block block] -> Chain block -> Maybe (Chain block)
forall block.
HasHeader block =>
[ChainUpdate block block] -> Chain block -> Maybe (Chain block)
applyChainUpdates [ChainUpdate block block]
us (Chain block -> Maybe (Chain block))
-> Maybe (Chain block) -> Maybe (Chain block)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ChainUpdate block block -> Chain block -> Maybe (Chain block)
forall block.
HasHeader block =>
ChainUpdate block block -> Chain block -> Maybe (Chain block)
applyChainUpdate ChainUpdate block block
u Chain block
c

-- | Select a bunch of 'Point's based on offsets from the head of the chain.
-- This is used in the chain consumer protocol as part of finding the
-- intersection between a local and remote chain.
--
-- The typical pattern is to use a selection of offsets covering the last K
-- blocks, biased towards more recent blocks. For example:
--
-- > selectPoints (0 : [ fib n | n <- [1 .. 17] ])
--
selectPoints :: HasHeader block => [Int] -> Chain block -> [Point block]
selectPoints :: forall block.
HasHeader block =>
[Int] -> Chain block -> [Point block]
selectPoints [Int]
offsets =
    [Int] -> Chain block -> [Point block]
forall block.
HasHeader block =>
[Int] -> Chain block -> [Point block]
go [Int]
relativeOffsets
  where
    relativeOffsets :: [Int]
relativeOffsets = (Int -> Int -> Int) -> [Int] -> [Int] -> [Int]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (-) [Int]
offsets (Int
0Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
offsets)
    go :: [Int] -> Chain block -> [Point block]
go [] Chain block
_         = []
    go [Int]
_  Chain block
Genesis   = []
    go (Int
off:[Int]
offs) Chain block
c = Chain block -> Point block
forall block. HasHeader block => Chain block -> Point block
headPoint Chain block
c' Point block -> [Point block] -> [Point block]
forall a. a -> [a] -> [a]
: [Int] -> Chain block -> [Point block]
go [Int]
offs Chain block
c'
      where
        c' :: Chain block
c' = Int -> Chain block -> Chain block
forall block. Int -> Chain block -> Chain block
drop Int
off Chain block
c

findBlock
  :: (block -> Bool)
  -> Chain block
  -> Maybe block
findBlock :: forall block. (block -> Bool) -> Chain block -> Maybe block
findBlock block -> Bool
_ Chain block
Genesis  = Maybe block
forall a. Maybe a
Nothing
findBlock block -> Bool
p (Chain block
c :> block
b)
  | block -> Bool
p block
b              = block -> Maybe block
forall a. a -> Maybe a
Just block
b
  | Bool
otherwise        = (block -> Bool) -> Chain block -> Maybe block
forall block. (block -> Bool) -> Chain block -> Maybe block
findBlock block -> Bool
p Chain block
c

selectBlockRange :: HasHeader block
                 => Chain block
                 -> Point block
                 -> Point block
                 -> Maybe [block]
selectBlockRange :: forall block.
HasHeader block =>
Chain block -> Point block -> Point block -> Maybe [block]
selectBlockRange Chain block
c Point block
from Point block
to
  | Point block -> Chain block -> Bool
forall block. HasHeader block => Point block -> Chain block -> Bool
pointOnChain Point block
from Chain block
c
  , Point block -> Chain block -> Bool
forall block. HasHeader block => Point block -> Chain block -> Bool
pointOnChain Point block
to Chain block
c
  =   [block] -> Maybe [block]
forall a. a -> Maybe a
Just
    ([block] -> Maybe [block])
-> (Chain block -> [block]) -> Chain block -> Maybe [block]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [block] -> [block]
forall a. [a] -> [a]
reverse
    ([block] -> [block])
-> (Chain block -> [block]) -> Chain block -> [block]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (block -> Bool) -> [block] -> [block]
forall a. (a -> Bool) -> [a] -> [a]
Prelude.takeWhile (\block
b -> block -> Point block
forall block. HasHeader block => block -> Point block
blockPoint block
b Point block -> Point block -> Bool
forall a. Eq a => a -> a -> Bool
/= Point block
from)
    ([block] -> [block])
-> (Chain block -> [block]) -> Chain block -> [block]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (block -> Bool) -> [block] -> [block]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (\block
b -> block -> Point block
forall block. HasHeader block => block -> Point block
blockPoint block
b Point block -> Point block -> Bool
forall a. Eq a => a -> a -> Bool
/= Point block
to)
    ([block] -> [block])
-> (Chain block -> [block]) -> Chain block -> [block]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Chain block -> [block]
forall block. Chain block -> [block]
toNewestFirst
    (Chain block -> Maybe [block]) -> Chain block -> Maybe [block]
forall a b. (a -> b) -> a -> b
$ Chain block
c

  | Bool
otherwise
  = Maybe [block]
forall a. Maybe a
Nothing

findFirstPoint
  :: HasHeader block
  => [Point block]
  -> Chain block
  -> Maybe (Point block)
findFirstPoint :: forall block.
HasHeader block =>
[Point block] -> Chain block -> Maybe (Point block)
findFirstPoint [] Chain block
_     = Maybe (Point block)
forall a. Maybe a
Nothing
findFirstPoint (Point block
p:[Point block]
ps) Chain block
c
  | Point block -> Chain block -> Bool
forall block. HasHeader block => Point block -> Chain block -> Bool
pointOnChain Point block
p Chain block
c    = Point block -> Maybe (Point block)
forall a. a -> Maybe a
Just Point block
p
  | Bool
otherwise           = [Point block] -> Chain block -> Maybe (Point block)
forall block.
HasHeader block =>
[Point block] -> Chain block -> Maybe (Point block)
findFirstPoint [Point block]
ps Chain block
c

intersectChains
  :: HasHeader block
  => Chain block
  -> Chain block
  -> Maybe (Point block)
intersectChains :: forall block.
HasHeader block =>
Chain block -> Chain block -> Maybe (Point block)
intersectChains Chain block
_ Chain block
Genesis   = Maybe (Point block)
forall a. Maybe a
Nothing
intersectChains Chain block
c (Chain block
bs :> block
b) =
  let p :: Point block
p = block -> Point block
forall block. HasHeader block => block -> Point block
blockPoint block
b
  in if Point block -> Chain block -> Bool
forall block. HasHeader block => Point block -> Chain block -> Bool
pointOnChain (block -> Point block
forall block. HasHeader block => block -> Point block
blockPoint block
b) Chain block
c
       then Point block -> Maybe (Point block)
forall a. a -> Maybe a
Just Point block
p
       else Chain block -> Chain block -> Maybe (Point block)
forall block.
HasHeader block =>
Chain block -> Chain block -> Maybe (Point block)
intersectChains Chain block
c Chain block
bs

-- * Conversions to/from 'AnchoredFragment'

-- | Convert a 'Chain' to an 'AnchoredFragment'.
--
-- The anchor of the fragment will be 'Chain.genesisPoint'.
toAnchoredFragment :: HasHeader block => Chain block -> AF.AnchoredFragment block
toAnchoredFragment :: forall block.
HasHeader block =>
Chain block -> AnchoredFragment block
toAnchoredFragment = Anchor block
-> [block] -> AnchoredSeq (WithOrigin SlotNo) (Anchor block) block
forall v a b. Anchorable v a b => a -> [b] -> AnchoredSeq v a b
AF.fromOldestFirst Anchor block
forall block. Anchor block
AF.AnchorGenesis ([block] -> AnchoredSeq (WithOrigin SlotNo) (Anchor block) block)
-> (Chain block -> [block])
-> Chain block
-> AnchoredSeq (WithOrigin SlotNo) (Anchor block) block
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Chain block -> [block]
forall block. Chain block -> [block]
toOldestFirst

-- | Convert an 'AnchoredFragment' to a 'Chain'.
--
-- The anchor of the fragment must be 'Chain.genesisPoint', otherwise
-- 'Nothing' is returned.
fromAnchoredFragment :: HasHeader block => AF.AnchoredFragment block -> Maybe (Chain block)
fromAnchoredFragment :: forall block.
HasHeader block =>
AnchoredFragment block -> Maybe (Chain block)
fromAnchoredFragment AnchoredFragment block
af
    | AnchoredFragment block -> Point block
forall block. AnchoredFragment block -> Point block
AF.anchorPoint AnchoredFragment block
af Point block -> Point block -> Bool
forall a. Eq a => a -> a -> Bool
== Point block
forall {k} (block :: k). Point block
genesisPoint
    = Chain block -> Maybe (Chain block)
forall a. a -> Maybe a
Just (Chain block -> Maybe (Chain block))
-> Chain block -> Maybe (Chain block)
forall a b. (a -> b) -> a -> b
$ [block] -> Chain block
forall block. HasHeader block => [block] -> Chain block
fromNewestFirst ([block] -> Chain block) -> [block] -> Chain block
forall a b. (a -> b) -> a -> b
$ AnchoredFragment block -> [block]
forall v a b. AnchoredSeq v a b -> [b]
AF.toNewestFirst AnchoredFragment block
af
    | Bool
otherwise
    = Maybe (Chain block)
forall a. Maybe a
Nothing

--
-- Serialisation
--

instance Serialise block => Serialise (Chain block) where

  encode :: Chain block -> Encoding
encode Chain block
c = Word -> Encoding
encodeListLen (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word) -> Int -> Word
forall a b. (a -> b) -> a -> b
$ Chain block -> Int
forall block. Chain block -> Int
length Chain block
c)
          Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> (Encoding -> block -> Encoding)
-> Encoding -> Chain block -> Encoding
forall a b. (a -> b -> a) -> a -> Chain b -> a
foldChain (\Encoding
e block
b -> Encoding
e Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> block -> Encoding
forall a. Serialise a => a -> Encoding
encode block
b) Encoding
forall a. Monoid a => a
mempty Chain block
c

  decode :: forall s. Decoder s (Chain block)
decode = do
      n <- Decoder s Int
forall s. Decoder s Int
decodeListLen
      go genesis n
    where
      go :: Chain block -> t -> Decoder s (Chain block)
go Chain block
c t
0 = Chain block -> Decoder s (Chain block)
forall a. a -> Decoder s a
forall (m :: * -> *) a. Monad m => a -> m a
return Chain block
c
      go Chain block
c t
n = do b <- Decoder s block
forall s. Decoder s block
forall a s. Serialise a => Decoder s a
decode
                  go (c :> b) (n-1)