{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE StandaloneDeriving   #-}
{-# LANGUAGE TypeFamilies         #-}
{-# LANGUAGE UndecidableInstances #-}
-- | Intended for qualified import
--
-- > import Ouroboros.Consensus.Fragment.Diff (ChainDiff (..))
-- > import qualified Ouroboros.Consensus.Fragment.Diff as Diff
module Ouroboros.Consensus.Fragment.Diff (
    ChainDiff (..)
    -- * Queries
  , getAnchorPoint
  , getTip
  , rollbackExceedsSuffix
    -- * Constructors
  , diff
  , extend
    -- * Application
  , apply
    -- * Manipulation
  , append
  , mapM
  , takeWhileOldest
  , truncate
  ) where

import           Prelude hiding (mapM, truncate)
import qualified Prelude

import           Data.Word (Word64)
import           GHC.Stack (HasCallStack)

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

import           Ouroboros.Consensus.Block


-- | A diff of a chain (fragment).
--
-- Typical instantiations of the type argument @b@: a block type @blk@,
-- @Header blk@, @HeaderFields@, ..., anything that supports 'HasHeader'.
--
-- Note: we allow the suffix to be shorter than the number of blocks to roll
-- back. In other words, applying a 'ChainDiff' can result in a chain shorter
-- than the chain to which the diff was applied.
data ChainDiff b = ChainDiff
    { ChainDiff b -> Word64
getRollback :: !Word64
      -- ^ The number of blocks/headers to roll back the current chain
    , ChainDiff b -> AnchoredFragment b
getSuffix   :: !(AnchoredFragment b)
      -- ^ The new blocks/headers to add after rolling back the current chain.
    }

deriving instance (StandardHash b, Eq   b) => Eq   (ChainDiff b)
deriving instance (StandardHash b, Show b) => Show (ChainDiff b)

{-------------------------------------------------------------------------------
  Queries
-------------------------------------------------------------------------------}

-- | Return the tip of the new suffix
getTip :: HasHeader b => ChainDiff b -> Point b
getTip :: ChainDiff b -> Point b
getTip = Point b -> Point b
forall b b'.
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point b -> Point b)
-> (ChainDiff b -> Point b) -> ChainDiff b -> Point b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredFragment b -> Point b
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.headPoint (AnchoredFragment b -> Point b)
-> (ChainDiff b -> AnchoredFragment b) -> ChainDiff b -> Point b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainDiff b -> AnchoredFragment b
forall b. ChainDiff b -> AnchoredFragment b
getSuffix

-- | Return the anchor point of the new suffix
getAnchorPoint :: ChainDiff b -> Point b
getAnchorPoint :: ChainDiff b -> Point b
getAnchorPoint = Point b -> Point b
forall b b'.
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point b -> Point b)
-> (ChainDiff b -> Point b) -> ChainDiff b -> Point b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredFragment b -> Point b
forall block. AnchoredFragment block -> Point block
AF.anchorPoint (AnchoredFragment b -> Point b)
-> (ChainDiff b -> AnchoredFragment b) -> ChainDiff b -> Point b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainDiff b -> AnchoredFragment b
forall b. ChainDiff b -> AnchoredFragment b
getSuffix

-- | Return 'True' iff applying the 'ChainDiff' to a chain @C@ will result in
-- a chain shorter than @C@, i.e., the number of blocks to roll back is
-- greater than the length of the new elements in the suffix to add.
rollbackExceedsSuffix :: HasHeader b => ChainDiff b -> Bool
rollbackExceedsSuffix :: ChainDiff b -> Bool
rollbackExceedsSuffix (ChainDiff Word64
nbRollback AnchoredFragment b
suffix) =
    Word64
nbRollback Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> 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
suffix)

{-------------------------------------------------------------------------------
  Constructors
-------------------------------------------------------------------------------}

-- | Make an extension-only (no rollback) 'ChainDiff'.
extend :: AnchoredFragment b -> ChainDiff b
extend :: AnchoredFragment b -> ChainDiff b
extend = Word64 -> AnchoredFragment b -> ChainDiff b
forall b. Word64 -> AnchoredFragment b -> ChainDiff b
ChainDiff Word64
0

-- | Diff a candidate chain with the current chain.
--
-- If the candidate fragment is shorter than the current chain, 'Nothing' is
-- returned (this would violate the invariant of 'ChainDiff').
--
-- PRECONDITION: the candidate fragment must intersect with the current chain
-- fragment.
diff
  :: (HasHeader b, HasCallStack)
  => AnchoredFragment b  -- ^ Current chain
  -> AnchoredFragment b  -- ^ Candidate chain
  -> ChainDiff b
diff :: AnchoredFragment b -> AnchoredFragment b -> ChainDiff b
diff AnchoredFragment b
curChain AnchoredFragment b
candChain =
  case 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
curChain AnchoredFragment b
candChain of
    Just (AnchoredFragment b
_curChainPrefix, AnchoredFragment b
_candPrefix, AnchoredFragment b
curChainSuffix, AnchoredFragment b
candSuffix)
      -> Word64 -> AnchoredFragment b -> ChainDiff b
forall b. Word64 -> AnchoredFragment b -> ChainDiff b
ChainDiff
           (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
curChainSuffix))
           AnchoredFragment b
candSuffix
    -- Precondition violated.
    Maybe
  (AnchoredFragment b, AnchoredFragment b, AnchoredFragment b,
   AnchoredFragment b)
_ -> String -> ChainDiff b
forall a. HasCallStack => String -> a
error String
"candidate fragment doesn't intersect with current chain"

{-------------------------------------------------------------------------------
  Application
-------------------------------------------------------------------------------}

-- | Apply the 'ChainDiff' on the given chain fragment.
--
-- The fragment is first rolled back a number of blocks before appending the
-- new suffix.
--
-- If the 'ChainDiff' doesn't fit (anchor point mismatch), 'Nothing' is
-- returned.
--
-- The returned fragment will have the same anchor point as the given
-- fragment.
apply
  :: HasHeader b
  => AnchoredFragment b
  -> ChainDiff b
  -> Maybe (AnchoredFragment b)
apply :: AnchoredFragment b -> ChainDiff b -> Maybe (AnchoredFragment b)
apply AnchoredFragment b
curChain (ChainDiff Word64
nbRollback AnchoredFragment b
suffix) =
    AnchoredFragment b
-> AnchoredFragment b -> Maybe (AnchoredFragment b)
forall block.
HasHeader block =>
AnchoredFragment block
-> AnchoredFragment block -> Maybe (AnchoredFragment block)
AF.join (Int -> AnchoredFragment b -> AnchoredFragment b
forall v a b.
Anchorable v a b =>
Int -> AnchoredSeq v a b -> AnchoredSeq v a b
AF.dropNewest (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
nbRollback) AnchoredFragment b
curChain) AnchoredFragment b
suffix

{-------------------------------------------------------------------------------
  Manipulation
-------------------------------------------------------------------------------}

-- | Append a @b@ to a 'ChainDiff'.
--
-- PRECONDITION: it must fit onto the end of the suffix.
append :: HasHeader b => ChainDiff b -> b -> ChainDiff b
append :: ChainDiff b -> b -> ChainDiff b
append (ChainDiff Word64
nbRollback AnchoredFragment b
suffix) b
b = (Word64 -> AnchoredFragment b -> ChainDiff b
forall b. Word64 -> AnchoredFragment b -> ChainDiff b
ChainDiff Word64
nbRollback (AnchoredFragment b
suffix AnchoredFragment b -> b -> AnchoredFragment b
forall v a b.
Anchorable v a b =>
AnchoredSeq v a b -> b -> AnchoredSeq v a b
:> b
b))

-- | Truncate the diff by rolling back the new suffix to the given point.
--
-- PRECONDITION: the given point must correspond to one of the new
-- blocks/headers of the new suffix or its anchor (i.e,
-- @'AF.withinFragmentBounds' pt (getSuffix diff)@).
--
-- If the length of the truncated suffix is shorter than the rollback,
-- 'Nothing' is returned.
truncate
  :: (HasHeader b, HasCallStack)
  => Point b
  -> ChainDiff b
  -> ChainDiff b
truncate :: Point b -> ChainDiff b -> ChainDiff b
truncate Point b
pt (ChainDiff Word64
nbRollback AnchoredFragment b
suffix)
    | Just AnchoredFragment b
suffix' <- Point b -> AnchoredFragment b -> Maybe (AnchoredFragment b)
forall block.
HasHeader block =>
Point block
-> AnchoredFragment block -> Maybe (AnchoredFragment block)
AF.rollback (Point b -> Point b
forall b b'.
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint Point b
pt) AnchoredFragment b
suffix
    = Word64 -> AnchoredFragment b -> ChainDiff b
forall b. Word64 -> AnchoredFragment b -> ChainDiff b
ChainDiff Word64
nbRollback AnchoredFragment b
suffix'
    | Bool
otherwise
    = String -> ChainDiff b
forall a. HasCallStack => String -> a
error (String -> ChainDiff b) -> String -> ChainDiff b
forall a b. (a -> b) -> a -> b
$ String
"rollback point not on the candidate suffix: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Point b -> String
forall a. Show a => a -> String
show Point b
pt

-- | Return the longest prefix of the suffix matching the given predicate,
-- starting from the left, i.e., the \"oldest\" blocks.
--
-- If the new suffix is shorter than the diff's rollback, return 'Nothing'.
takeWhileOldest
  :: HasHeader b
  => (b -> Bool)
  -> ChainDiff b
  -> ChainDiff b
takeWhileOldest :: (b -> Bool) -> ChainDiff b -> ChainDiff b
takeWhileOldest b -> Bool
accept (ChainDiff Word64
nbRollback AnchoredFragment b
suffix) =
    Word64 -> AnchoredFragment b -> ChainDiff b
forall b. Word64 -> AnchoredFragment b -> ChainDiff b
ChainDiff Word64
nbRollback ((b -> Bool) -> AnchoredFragment b -> AnchoredFragment b
forall v a b.
Anchorable v a b =>
(b -> Bool) -> AnchoredSeq v a b -> AnchoredSeq v a b
AF.takeWhileOldest b -> Bool
accept AnchoredFragment b
suffix)

mapM
  :: forall a b m.
     ( HasHeader b
     , HeaderHash a ~ HeaderHash b
     , Monad m
     )
  => (a -> m b)
  -> ChainDiff a
  -> m (ChainDiff b)
mapM :: (a -> m b) -> ChainDiff a -> m (ChainDiff b)
mapM a -> m b
f (ChainDiff Word64
rollback AnchoredFragment a
suffix) =
       Word64 -> AnchoredFragment b -> ChainDiff b
forall b. Word64 -> AnchoredFragment b -> ChainDiff b
ChainDiff Word64
rollback
    (AnchoredFragment b -> ChainDiff b)
-> ([b] -> AnchoredFragment b) -> [b] -> ChainDiff b
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  Anchor b -> [b] -> AnchoredFragment b
forall v a b. Anchorable v a b => a -> [b] -> AnchoredSeq v a b
AF.fromOldestFirst (Anchor a -> Anchor b
forall a b. (HeaderHash a ~ HeaderHash b) => Anchor a -> Anchor b
AF.castAnchor (AnchoredFragment a -> Anchor a
forall v a b. AnchoredSeq v a b -> a
AF.anchor AnchoredFragment a
suffix))
   ([b] -> ChainDiff b) -> m [b] -> m (ChainDiff b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> m b) -> [a] -> m [b]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
Prelude.mapM a -> m b
f (AnchoredFragment a -> [a]
forall v a b. AnchoredSeq v a b -> [b]
AF.toOldestFirst AnchoredFragment a
suffix)