{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ParallelListComp #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

-- |
-- Module: Chainweb.Cut
-- Copyright: Copyright © 2018 Kadena LLC.
-- License: MIT
-- Maintainer: Lars Kuhtz <lars@kadena.io>
-- Stability: experimental
--
-- A cut represents the a distributed state of a concurrent computation.
--
-- In the context of Chainweb it contains one block for each chain (possibly of
-- a subset of all chains) that any pair of two blocks in the cut either
-- directly depend on each other or are independent from each other.
--
-- Intuitively, a cut is a set of blocks from different chains that can (but
-- doesn't have to) occur at the same time as the head of their respective
-- chains.
--
module Chainweb.Cut
( Cut
, cutToTextShort
, cutDiffToTextShort
, _cutHeaders
, cutHeaders
, _cutMap
, cutMap
, _cutHeight
, cutHeight
, _cutWeight
, cutWeight
, _cutMinHeight
, cutMinHeight
, _cutMaxHeight
, cutMaxHeight
, _cutIsTransition
, cutIsTransition

, _cutAdjPairs
, cutAdjPairs
, cutAdjs
, lookupCutM
, forkDepth
, limitCut
, tryLimitCut
, limitCutHeaders
, unsafeMkCut
, chainHeights

-- * Exceptions
, CutException(..)

-- * Genesis Cut
, genesisCut

-- * Checks
, checkBraidingOfCut
, checkBraidingOfCutPairs
, checkBraidingOfCutPair
, isBraidingOfCutPair

-- * Extending Cuts
, isMonotonicCutExtension
, monotonicCutExtension
, tryMonotonicCutExtension

-- * Join
, Join(..)
, join
, applyJoin
, prioritizeHeavier
, prioritizeHeavier_
, joinIntoHeavier
, joinIntoHeavier_

-- * Meet
, meet

) where

import Control.DeepSeq
import Control.Exception hiding (catch)
import Control.Lens hiding ((:>), (.=))
import Control.Monad hiding (join)
import Control.Monad.Catch

import Data.Bifoldable
import Data.Foldable
import Data.Function
import Data.Functor.Of
import qualified Data.HashMap.Strict as HM
import qualified Data.HashSet as HS
import qualified Data.Heap as H
import qualified Data.List as List
import Data.Maybe (fromMaybe)
import Data.Monoid
import Data.Ord
import Data.Text (Text)
import qualified Data.Text as T
import Data.These

import GHC.Generics (Generic)
import GHC.Stack

import Numeric.Natural

import Prelude hiding (lookup)

import qualified Streaming.Prelude as S

-- internal modules

import Chainweb.BlockHash
import Chainweb.BlockHeader
import Chainweb.BlockHeight
import Chainweb.BlockWeight
import Chainweb.ChainId
import Chainweb.Graph
import Chainweb.TreeDB
import Chainweb.Utils
import Chainweb.Version
import Chainweb.Version.Utils
import Chainweb.WebBlockHeaderDB
import Control.Monad.State.Strict

-- -------------------------------------------------------------------------- --
-- Cut

-- | A cut is a distributed state of a concurrent computation. Formally, a cut
-- satisfies the property
--
-- * prop_cutBraiding
--
-- A cut also satisfies the properties that
--
-- * the graph is valid,
-- * the graph corresponds to the 'ChainwebVersion',
-- * the set of 'ChainId's of the cut are exactly the vertices of the graph,
-- * all blockHeaders are valid (which is guaranteed by 'genesisBlockHeader')
--   with respect to the graph.
--
-- A cut can be created in the following ways and only in the following ways:
--
-- 1. 'genesisCut',
-- 2. 'monotonicCutExtension' and 'tryMonotonicCutExtension',
-- 3. 'applyJoin' (preceeded by 'join'),
-- 4. 'limitCut' and 'tryLimitCut'.
--
-- On startup a cut is created by
-- 5. deserializing the cut that is persisted in the local cutDB.
--
-- There are a few more methods (like for instance 'meet') that are not relevant
-- for production scenarios.
--
-- The above methods use either the 'Cut\'' constructor or the 'unsafeCutHeaders'
-- function, both of which are not exported from this module.
--
data Cut = Cut'
    { _cutHeaders' :: !(HM.HashMap ChainId BlockHeader)
    , _cutChainwebVersion' :: !ChainwebVersion

    -- Memoize properties that have linear compute cost
    , _cutHeight' :: {- lazy -} CutHeight
    , _cutMinHeight' :: {- lazy -} BlockHeight
    , _cutMaxHeight' :: {- lazy -} BlockHeight
    , _cutWeight' :: {- lazy -} BlockWeight
    , _cutIsTransition' :: {- lazy -} Bool
    }
    deriving (Show, Eq, Ord, Generic)
    deriving anyclass (NFData)

_cutHeaders :: Cut -> (HM.HashMap ChainId BlockHeader)
_cutHeaders = _cutHeaders'
{-# INLINE cutHeaders #-}

cutHeaders :: Getter Cut (HM.HashMap ChainId BlockHeader)
cutHeaders = to _cutHeaders
{-# INLINE _cutHeaders #-}

_cutMap :: Cut -> HM.HashMap ChainId BlockHeader
_cutMap = _cutHeaders
{-# INLINE _cutMap #-}

cutMap :: Getter Cut (HM.HashMap ChainId BlockHeader)
cutMap = cutHeaders
{-# INLINE cutMap #-}

_cutChainwebVersion :: Cut -> ChainwebVersion
_cutChainwebVersion = _cutChainwebVersion'
{-# INLINE _cutChainwebVersion #-}

cutChainwebVersion :: Getter Cut ChainwebVersion
cutChainwebVersion = to _cutChainwebVersion
{-# INLINE cutChainwebVersion #-}

_cutWeight :: Cut -> BlockWeight
_cutWeight = _cutWeight'
{-# INLINE _cutWeight #-}

cutWeight :: Getter Cut BlockWeight
cutWeight = to _cutWeight
{-# INLINE cutWeight #-}

_cutHeight :: Cut -> CutHeight
_cutHeight = _cutHeight'
{-# INLINE _cutHeight #-}

cutHeight :: Getter Cut CutHeight
cutHeight = to _cutHeight
{-# INLINE cutHeight #-}

_cutMinHeight :: Cut -> BlockHeight
_cutMinHeight = _cutMinHeight'
{-# INLINE _cutMinHeight #-}

cutMinHeight :: Getter Cut BlockHeight
cutMinHeight = to _cutMinHeight
{-# INLINE cutMinHeight #-}

_cutMaxHeight :: Cut -> BlockHeight
_cutMaxHeight = _cutMaxHeight'
{-# INLINE _cutMaxHeight #-}

cutMaxHeight :: Getter Cut BlockHeight
cutMaxHeight = to _cutMaxHeight
{-# INLINE cutMaxHeight #-}

_cutIsTransition :: Cut -> Bool
_cutIsTransition = _cutIsTransition'
{-# INLINE _cutIsTransition #-}

cutIsTransition :: Getter Cut Bool
cutIsTransition = to _cutIsTransition
{-# INLINE cutIsTransition #-}

-- | The chain graph is the graph at the /minimum/ height of the block headers
-- in the cut.
--
instance HasChainGraph Cut where
    _chainGraph c = chainGraphAt (_chainwebVersion c) (_cutMinHeight c)
    {-# INLINE _chainGraph #-}

instance HasChainwebVersion Cut where
    _chainwebVersion = view cutChainwebVersion
    {-# INLINE _chainwebVersion #-}

type instance Index Cut = ChainId
type instance IxValue Cut = BlockHeader

instance IxedGet Cut where
    ixg i = cutHeaders . ix i
    {-# INLINE ixg #-}

lookupCutM
    :: MonadThrow m
    => HasChainId cid
    => cid
    -> Cut
    -> m BlockHeader
lookupCutM cid c = firstOf (ixg (_chainId cid)) c
    ??? ChainNotInChainGraphException
        (Expected $ chainIds c)
        (Actual (_chainId cid))

unsafeMkCut :: ChainwebVersion -> HM.HashMap ChainId BlockHeader -> Cut
unsafeMkCut v hdrs = Cut'
    { _cutHeaders' = hdrs
    , _cutChainwebVersion' = v
    , _cutHeight' = int $ sum $ view blockHeight <$> hdrs
    , _cutWeight' = sum $ view blockWeight <$> hdrs
    , _cutMinHeight' = minimum $ view blockHeight <$> hdrs
    , _cutMaxHeight' = maximum $ view blockHeight <$> hdrs
    , _cutIsTransition' =  minheight < lastGraphChange v (maxheight)
    }
  where
    minheight = minimum $ view blockHeight <$> hdrs
    maxheight = maximum $ view blockHeight <$> hdrs

-- -------------------------------------------------------------------------- --
-- Adjacents
--
-- Note that in a cut adjacency is directed. The reason is that the headers in a
-- cut may be of different height and may thus use different graphs.

-- | Map of adjacent block headers for a chain in a cut. The function considers
-- the block height for the respective chain in the given cut.
--
-- Assumes that the cid exists in the graph.
--
cutAdjs
    :: HasChainId cid
    => Cut
    -> cid
    -> HM.HashMap ChainId BlockHeader
cutAdjs c = HM.intersection (_cutHeaders c) . HS.toMap . cutAdjChainIds c
{-# INLINE cutAdjs #-}

-- | Adjacent chain ids for a chain in a cut. The function considers the block
-- height for the respective chain in the given cut.
--
-- Assumes that the cid exists in the graph.
--
cutAdjChainIds :: HasChainId cid => Cut -> cid -> HS.HashSet ChainId
cutAdjChainIds c cid = c ^?! ixg (_chainId cid) . blockAdjacentChainIds
{-# INLINE cutAdjChainIds #-}

-- | /Directed/ adjacent pairs of a cut. Note that block headers in a cut can be
-- of different block height and can thus use different chain graphs.
--
_cutAdjPairs :: Cut -> [(BlockHeader, BlockHeader)]
_cutAdjPairs c = do
    (cid, h) <- HM.toList (_cutMap c)
    x <- toList (cutAdjs c cid)
    return (h, x)
{-# INLINE _cutAdjPairs #-}

cutAdjPairs :: Getter Cut [(BlockHeader, BlockHeader)]
cutAdjPairs = to _cutAdjPairs
{-# INLINE cutAdjPairs #-}

-- -------------------------------------------------------------------------- --
-- Chain Heights

chainHeights :: Cut -> [BlockHeight]
chainHeights = fmap (view blockHeight) . toList . _cutHeaders
{-# INLINE chainHeights #-}

-- -------------------------------------------------------------------------- --
-- Tools for Graph Transitions
--
-- These functions are used to adjust the available chains during construction
-- of new cuts:
--
-- * 'monotonicCutExtension' and 'tryMonotonicCutExtension': extend the
--   resulting cut with genesis headers of new chains.
--
-- * 'limitCut': project out chains that don't exist in the result cut.
--
-- * 'join' and 'applyJoin': add chains from both cuts to the input cuts, so
--   that all chains are available in the join base and can be restored during
--   'applyJoin'; project out non-existing chains in the result.
--
-- The graph is determined by the /minimum/ height of the blocks in the cut.
--
-- The minimum is used to ensure that cuts in a new graph only exist when /all/
-- blocks are on the new cut. This means the new chains are included only if all
-- old chains have transitioned to the minimum block height of the new graph.

cutHeadersMinHeight :: HM.HashMap ChainId BlockHeader -> BlockHeight
cutHeadersMinHeight = minimum . fmap (view blockHeight)
{-# INLINE cutHeadersMinHeight #-}

cutHeadersChainwebVersion :: HM.HashMap ChainId BlockHeader -> ChainwebVersion
cutHeadersChainwebVersion m = _chainwebVersion $ unsafeHead "Chainweb.Cut.cutHeadersChainwebVersion" $ toList m
{-# INLINE cutHeadersChainwebVersion #-}

-- | The function projects onto the chains available at the minimum block height
-- in input headers.
--
-- At a graph change chains are considered blocked until "all" chains performed
-- the transition to the new graph. Thus, a block in the new graph has all of
-- its dependencies available.
--
-- This an internal function. The result is meaningful only if the input headers
-- form a valid cut. In particular, the input must not be empty.
--
projectChains
    :: HM.HashMap ChainId BlockHeader
    -> HM.HashMap ChainId BlockHeader
projectChains m = HM.intersection m
    $ HS.toMap
    $ chainIdsAt (cutHeadersChainwebVersion m) (cutHeadersMinHeight m)
{-# INLINE projectChains #-}

cutProjectChains :: Cut -> Cut
cutProjectChains c = unsafeMkCut v $ projectChains $ _cutHeaders c
  where
    v = _chainwebVersion c
{-# INLINE cutProjectChains #-}

-- | Extend the chains for the graph at the minimum block height of the input
-- headers. If a header for a chain is missing the genesis block header for that
-- chain is added.
--
-- This an internal function. The result is meaningful only if the input headers
-- form a valid cut. In particular, the input must not be empty.
--
extendChains
    :: HM.HashMap ChainId BlockHeader
    -> HM.HashMap ChainId BlockHeader
extendChains m = HM.union m
    $ genesisBlockHeadersAtHeight
        (cutHeadersChainwebVersion m)
        (cutHeadersMinHeight m)
{-# INLINE extendChains #-}

-- | This function adds all chains that are available in either of the input
-- headers. It is assumed that both input header maps are contain headers for
-- all chains for the graph at the respective minimum height of the headers.
--
-- This function is used when dealing with joins that internally compute an
-- intersection on the blocks on all chains, but the goal is to preserve blocks
-- from all chains.
--
-- This an internal function. The result is meaningful only if the input headers
-- form a valid cut. In particular, the input must not be empty.
--
joinChains
    :: HM.HashMap ChainId BlockHeader
    -> HM.HashMap ChainId BlockHeader
    -> (HM.HashMap ChainId BlockHeader, HM.HashMap ChainId BlockHeader)
joinChains a b = (HM.union a c, HM.union b c)
  where
    v = cutHeadersChainwebVersion a
    c = genesisBlockHeader v <$> a <> b
{-# INLINE joinChains #-}

-- -------------------------------------------------------------------------- --
-- Limit Cut Hashes By Height

-- | Find a `Cut` that is a predecessor of the given one, and that has a block
-- height that is smaller or equal the given height.
--
-- If the requested limit is larger or equal to the current height, the given
-- cut is returned.
--
-- Otherwise, the predecessor of the given cut at the given height on each chain
-- is returned.
--
limitCut
    :: HasCallStack
    => WebBlockHeaderDb
    -> BlockHeight
        -- ^ upper bound for the block height of each chain. This is not a tight
        -- bound.
    -> Cut
    -> IO Cut
limitCut wdb h c
    | all (\bh -> h >= view blockHeight bh) (view cutHeaders c) =
        return c
    | otherwise = do
        hdrs <- itraverse go $ view cutHeaders c
        return $! unsafeMkCut v $ projectChains $ HM.mapMaybe id hdrs
  where
    v = _chainwebVersion c

    go :: ChainId -> BlockHeader -> IO (Maybe BlockHeader)
    go cid bh = do
        if h >= view blockHeight bh
        then return (Just bh)
        else do
            !db <- getWebBlockHeaderDb wdb cid
            seekAncestor db bh (min (int $ view blockHeight bh) (int h))
        -- this is safe because it's guaranteed that the requested rank is
        -- smaller then the block height of the argument

-- | Find a `Cut` that is a predecessor of the given one, and that has a block
-- height that is as low as possible while not exceeding the given height and
-- including all of the chains in the given cut.
--
-- If the requested limit is larger or equal to the current height, the given
-- cut is returned.
--
tryLimitCut
    :: HasCallStack
    => WebBlockHeaderDb
    -> BlockHeight
        -- upper bound for the block height of each chain. This is not a tight bound.
    -> Cut
    -> IO Cut
tryLimitCut wdb h c
    | all (\bh -> h >= view blockHeight bh) (view cutHeaders c) =
        return c
    | otherwise = do
        hdrs <- itraverse go $ view cutHeaders c
        return $! unsafeMkCut v hdrs
  where
    v = _chainwebVersion wdb
    go :: ChainId -> BlockHeader -> IO BlockHeader
    go cid bh = do
        if h >= view blockHeight bh
        then return bh
        else do
            !db <- getWebBlockHeaderDb wdb cid
            -- this is safe because it's guaranteed that the requested rank is
            -- smaller then the block height of the argument
            let ancestorHeight = min (int $ view blockHeight bh) (int h)
            if ancestorHeight <= fromIntegral (genesisHeight v cid)
            then return $ genesisBlockHeader v cid
            else fromJuste <$> seekAncestor db bh ancestorHeight

-- | The resulting headers are valid cut headers only if the input headers are
-- valid cut headers, too. The inverse is not true.
--
limitCutHeaders
    :: HasCallStack
    => WebBlockHeaderDb
    -> BlockHeight
        -- ^ upper bound for the block height of each chain. This is not a tight bound.
    -> HM.HashMap ChainId BlockHeader
    -> IO (HM.HashMap ChainId BlockHeader)
limitCutHeaders whdb h ch = _cutHeaders <$> limitCut whdb h (unsafeMkCut v ch)
  where
    v = _chainwebVersion whdb

-- -------------------------------------------------------------------------- --
-- Genesis Cut

-- | The genesis cut for a chainweb version.
--
-- The genesis cut contains only the genesis headers at block height0 0.
--
-- This guarantees that
--
-- * the graph is valid,
-- * the graph corresponds to the 'ChainwebVersion',
-- * the set of 'ChainId's of the cut are the exactly the vertices of the graph,
-- * all blockHeaders are valid (which is guaranteed by 'genesisBlockHeader').
--
-- These properties are maintained as inductive invariants for all Cuts.
--
genesisCut
    :: ChainwebVersion
    -> Cut
genesisCut v = unsafeMkCut v (genesisBlockHeadersAtHeight v 0)

-- -------------------------------------------------------------------------- --
-- Exceptions

data CutException
    = InvalidCutPair BlockHeader BlockHeader
    | NonMonotonicCutExtension (Expected BlockHash) (Actual BlockHash) BlockHeader
    | InvalidCutExtension BlockHeader
    deriving (Show, Eq, Ord, Generic)

instance Exception CutException

-- -------------------------------------------------------------------------- --
-- Cut Properties

-- | Check that a cut is correctly braided.
--
-- This check is only needed for external cuts. Note, that for imported cuts
-- this must be checked recursively.
--
-- The implementation of this check here is expensive, namely \(O(m)\), where
-- \(m\) is the size of the chain graph, i.e. the order of the graph times the
-- degree. Usually, a more efficient way to check this property for a new cut is
-- to performm a join that starts with a meet with a local cut, where the local
-- cut is know to have this property.
--
-- Thus, the functions in this section are mostly used for assertions in tests.
-- They also serve as reference implementations and documentation.
--
checkBraidingOfCut :: MonadThrow m => Cut -> m ()
checkBraidingOfCut = checkBraidingOfCutPairs . _cutAdjPairs
{-# INLINE checkBraidingOfCut #-}

-- | Check that a set of adjacent pairs of a cut is correctly braided.
--
checkBraidingOfCutPairs
    :: MonadThrow m
    => Foldable f
    => f (BlockHeader, BlockHeader)
    -> m ()
checkBraidingOfCutPairs = traverse_ (uncurry checkBraidingOfCutPair)
{-# INLINE checkBraidingOfCutPairs #-}

-- | Checks that directed adjacent pair in a cut is correctly braided.
--
checkBraidingOfCutPair
    :: MonadThrow m
    => BlockHeader
        -- ^ Source header
    -> BlockHeader
        -- ^ target header
    -> m ()
checkBraidingOfCutPair s t = do
    unless (absBlockHeightDiff s t <= 1) $ throwM $ InvalidCutPair s t
    unlessM (isBraidingOfCutPair s t) $ throwM (InvalidCutPair s t)

-- | Returns whether a directed adjacent pair in a cut is correctly braided.
--
-- * throws 'ChainNotAdjacentException'
--
-- Assuming that all headers in the cut have the same graph, the following
-- condition for all undirected adjacent pairs in the cut would inductively
-- guarantee a valid braiding:
--
-- @
-- isBraidingOfCutPair (AdjPair a b) = do
--    ab <- getAdjacentHash b a -- adjacent of a on chain of b
--    ba <- getAdjacentHash a b -- adjacent of b on chain of a
--    return
--        $! (view blockParent a == ba && view blockParent b == ab)
--        || ab == view blockHash b
--        || ba == view blockHash a
-- @
--
-- The actual implementation is a it more complex because headers of different
-- height in a cut may use a different chain graph during the transition from one
-- graph to another graph: instead of undirected adjacent pairs the condition
-- considers directed adjacent pairs.
--
-- A corresponding function is currently implemented in 'Chainweb.Cut.Create'
--
-- TODO: unify the implementation of both. In particular make sure that the
-- function here that is used during validation is not more lenient than the
-- function used for extending cuts for mining.
--
isBraidingOfCutPair
    :: MonadThrow m
    => BlockHeader
        -- ^ Source header
    -> BlockHeader
        -- ^ target header
    -> m Bool
isBraidingOfCutPair a b = do
    ab <- getAdjacentHash b a -- adjacent of a on chain of b
    ba <- getAdjacentHash a b -- adjacent of b on chain of a
    return
        $! (view blockParent a == ba && view blockParent b == ab) -- same graph
        || (view blockHeight a > view blockHeight b) && ab == view blockHash b
        || (view blockHeight a < view blockHeight b) && True {- if same graph: ba == view blockHash a -}

-- -------------------------------------------------------------------------- --
-- Extending Cuts

-- | Extends a Cut monotonically, i.e. the replaced block header is the parent
-- of the added block header.
--
-- Checks
--
-- * block header is from the ChainGraph of the Cut
-- * result has valid braiding
-- * result is a cut
-- * update is monotonic
--
-- This includes a check that inductively maintains 'checkBraidingOfCut'.
--
-- FIXME: this must conform with 'isBraidingOfCutPair'. Double check that we
-- have test for this or check if the implementation can be shared.
--
-- TODO: do we have to check that the correct graph is used?
--
isMonotonicCutExtension
    :: HasCallStack
    => MonadThrow m
    => Cut
    -> BlockHeader
    -> m Bool
isMonotonicCutExtension c h = do
    checkBlockHeaderGraph h
    return $! monotonic && validBraiding
  where
    monotonic = view blockParent h == case c ^? ixg (_chainId h) . blockHash of
        Nothing -> error $ T.unpack $ "isMonotonicCutExtension.monotonic: missing parent in cut. " <> encodeToText h
        Just x -> x
    validBraiding = getAll $ ifoldMap
        (\cid -> All . validBraidingCid cid)
        (_getBlockHashRecord $ view blockAdjacentHashes h)

    validBraidingCid cid a
        | Just b <- c ^? ixg cid = view blockHash b == a || view blockParent b == a
        | view blockHeight h == genesisHeight v cid = a == genesisParentBlockHash v cid
        | otherwise = error $ T.unpack $ "isMonotonicCutExtension.validBraiding: missing adjacent parent on chain " <> toText cid <> " in cut. " <> encodeToText h

    v = _chainwebVersion c

-- | Extend a cut with a block header. Throws 'InvalidCutExtension' if the block
-- header isn't a monotonic cut extension.
--
monotonicCutExtension
    :: MonadThrow m
    => Cut
    -> BlockHeader
    -> m Cut
monotonicCutExtension c h = tryMonotonicCutExtension c h >>= \case
    Nothing -> throwM $ InvalidCutExtension h
    Just x -> return x

-- | Extend a cut with a block header. Returns 'Nothing' the block header isn't
-- a monotonic cut extension.
--
tryMonotonicCutExtension
    :: MonadThrow m
    => Cut
    -> BlockHeader
    -> m (Maybe Cut)
tryMonotonicCutExtension c h = isMonotonicCutExtension c h >>= \case
    False -> return Nothing
    True -> return $! Just
        $! unsafeMkCut v
        $ extendChains
        $ set (ix' (_chainId h)) h
        $ _cutHeaders c
  where
    v = _chainwebVersion c

-- -------------------------------------------------------------------------- --
-- Join

type DiffItem a = These a a

type JoinQueue a = H.Heap (H.Entry (BlockHeight, a) BlockHeader)

-- | This represents the Join of two cuts in an algorithmically convenient way.
--
data Join a = Join
    { _joinBase :: !Cut
        -- ^ the base of the join, the largest cut that is contained in both
        -- cuts, or when viewed as sets, the intersection.
    , _joinQueue :: !(JoinQueue a)
        -- ^ a queue of block headers from both cuts that allows construct
        -- the join cut from the join base.
    }

-- | This computes the join for cuts across all chains.
--
-- If you want to compute a join for cuts that include only a subset of all
-- chains.
--
join
    :: Ord a
    => WebBlockHeaderDb
    -> (DiffItem BlockHeader -> DiffItem (Maybe a))
    -> Cut
    -> Cut
    -> IO (Join a)
join wdb f = join_ wdb f `on` _cutHeaders

-- | This merges two maps from ChainIds to BlockHeaders such that the result is
-- a Cut. Note, however, that the resulting cut contains only the chain ids from
-- the intersection of the input maps.
--
-- NOTE: For this to work as expected make sure that both inputs contain all
-- chains that should be present in the output.
--
-- Adds genesis blocks for chains that are not yet active. This purpose of this
-- is to make sure that all chains of both inputs are preserved in the join, so
-- that the result of the join contains all chains of the original cuts.
-- Otherwise the join would contain only the intersection of all chains and any
-- information/blocks in the other chains would be lost when applying the join.
--
join_
    :: forall a
    . Ord a
    => WebBlockHeaderDb
    -> (DiffItem BlockHeader -> DiffItem (Maybe a))
    -> HM.HashMap ChainId BlockHeader
    -> HM.HashMap ChainId BlockHeader
    -> IO (Join a)
join_ wdb prioFun a b = do
    (m, h) <- runStateT (HM.traverseWithKey f (HM.intersectionWith (,) a' b')) mempty
    return $! Join (unsafeMkCut (_chainwebVersion wdb) m) h
  where
    (a', b') = joinChains a b

    f
        :: ChainId
        -> (BlockHeader, BlockHeader)
        -> StateT (JoinQueue a) IO BlockHeader
    f cid (x, y) = do
        !q <- get
        db <- getWebBlockHeaderDb wdb cid
        (q' :> !h) <- liftIO $ S.fold g q id $ branchDiff_ db x y
        put q'
        return h

    g :: JoinQueue a -> DiffItem BlockHeader -> JoinQueue a
    g q x = foldl' maybeInsert q $ zip (biList x) (biList (prioFun x))

    maybeInsert
        :: H.Heap (H.Entry (BlockHeight, a) BlockHeader)
        -> (BlockHeader, Maybe a)
        -> H.Heap (H.Entry (BlockHeight, a) BlockHeader)
    maybeInsert !q (_, Nothing) = q
    maybeInsert !q (!h, (Just !p)) = H.insert (H.Entry (view blockHeight h, p) h) q

-- This can't fail because of missing dependencies. It can't fail because
-- of conflict.
--
-- Non-existing chains are stripped from the result.
--
applyJoin :: MonadThrow m => Join a -> m Cut
applyJoin m = cutProjectChains
    <$> foldM
        (\c b -> fromMaybe c <$> tryMonotonicCutExtension c (H.payload b))
        (_joinBase m)
        (_joinQueue m)

-- | Merge two Cuts. If at least one of the input cuts had a valid braiding the
-- result is guaranteed to have a valid braiding for all blocks included in cut
-- and their ancestors.
--
-- This is because the merge starts with the intersection of both cuts, using
-- 'branchDiff_' on each chain, and constructs the merge cut using
-- 'tryMonotonicCutExtension'. If one of the inputs is correctly braided, so is
-- the intersection. 'tryMonotonicCutExtension' is guaranteed to maintain that
-- property.
--
-- Chains that aren't yet initialized are included in the join and later
-- stripped from the result.
--
-- If you want to compute a join for cuts that include only a subset of all
-- chains, make sure that @genesisBlockHeaders v@ only returns genesis headers
-- for those chains that you care about.
--
joinIntoHeavier
    :: WebBlockHeaderDb
    -> Cut
    -> Cut
    -> IO Cut
joinIntoHeavier wdb = joinIntoHeavier_ wdb `on` _cutHeaders

-- | Chains that aren't yet initialized are included in the join and later
-- stripped from the result.
--
-- If you want to compute a join for cuts that include only a subset of all
-- chains, make sure that @genesisBlockHeaders v@ only returns genesis headers
-- for those chains that you care about.
--
joinIntoHeavier_
    :: WebBlockHeaderDb
    -> HM.HashMap ChainId BlockHeader
    -> HM.HashMap ChainId BlockHeader
    -> IO Cut
joinIntoHeavier_ wdb a b = do
    m <- join_ wdb (prioritizeHeavier_ a b) a b
    applyJoin m

prioritizeHeavier :: Cut -> Cut -> DiffItem BlockHeader -> DiffItem (Maybe Int)
prioritizeHeavier = prioritizeHeavier_ `on` _cutHeaders

-- | Note: consider the weight of the recursive dependencies for the
-- priority of a block header. For that we would have to annotate the
-- block headers before putting them in the queue. To traverse only once,
-- we'd have to traverse the zipped cuts by height and not by chainid, which
-- could easily be done by merging/zipping the branch-diff streams.
--
prioritizeHeavier_
    :: Foldable f
    => Eq (f BlockHeader)
    => f BlockHeader
    -> f BlockHeader
    -> DiffItem BlockHeader
    -> DiffItem (Maybe Int)
prioritizeHeavier_ a b = f
  where
    heaviest = maxBy (compare `on` weight) a b
    w c = if c == heaviest then 0 else 1

    f (This _) = This (Just $ w a)
    f (That _) = That (Just $ w b)
    f (These _ _)
        | heaviest == a = These (Just 0) Nothing
        | otherwise = These Nothing (Just 0)

    weight c =
        ( sumOf (folded . blockWeight) c
            -- first sort by weight
        , sumOf (folded . blockHeight) c
            -- for scenarios with trivial difficulty height is added as
            -- secondary metrics

        -- NOTE:
        -- We could consider prioritizing the latest block in the cut here as
        -- first-level tie breaker. That would further incentivize miners to use
        -- a block creation time that is close to the real world time (note that
        -- blocks from the future are rejected, so post-dating blocks is risky
        -- for miners.)

        , List.sort (toList c)
            -- the block hashes of the cut are added as tie breaker in order
            -- to guarantee commutativity.
            --
        )

-- -------------------------------------------------------------------------- --
-- Cut Meet

-- | Intersection of cuts
--
meet
    :: WebBlockHeaderDb
    -> Cut
    -> Cut
    -> IO Cut
meet wdb a b = do
    !r <- imapM f $ HM.intersectionWith (,) (_cutHeaders a) (_cutHeaders b)
    return $! unsafeMkCut (_chainwebVersion wdb) r
  where
    f !cid (!x, !y) = do
        db <- getWebBlockHeaderDb wdb cid
        forkEntry db x y

forkDepth
    :: WebBlockHeaderDb
    -> Cut
    -> Cut
    -> IO Natural
forkDepth wdb a b = do
    m <- meet wdb a b
    return $! int $ max (maxDepth m a) (maxDepth m b)
  where
    maxDepth l u = maximum $ HM.intersectionWith
        (\x y -> view blockHeight y - view blockHeight x)
        (_cutHeaders l)
        (_cutHeaders u)

cutToTextShort :: Cut -> [Text]
cutToTextShort c =
    [ blockHeaderShortDescription bh
    | (_, bh) <- List.sortOn fst $ HM.toList (_cutHeaders c)
    ]

cutDiffToTextShort :: Cut -> Cut -> [Text]
cutDiffToTextShort c c' =
    [ T.unwords
        [ maybe "No block" blockHeaderShortDescription bh
        , "->"
        , maybe "No block" blockHeaderShortDescription bh'
        ]
    | cid <- List.sort $ HM.keys $ HM.union (_cutHeaders c) (_cutHeaders c')
    , let bh = HM.lookup cid (_cutHeaders c)
    , let bh' = HM.lookup cid (_cutHeaders c')
    , bh /= bh'
    ]