{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoFieldSelectors #-}

-- |
-- Module      : Haskoin.Block.Headers
-- Copyright   : No rights reserved
-- License     : MIT
-- Maintainer  : jprupp@protonmail.ch
-- Stability   : experimental
-- Portability : POSIX
--
-- Block chain header synchronization and proof-of-work consensus functions.
module Haskoin.Block.Headers
  ( -- * Block Headers
    BlockNode (..),
    BlockHeaders (..),
    BlockWork,
    genesisNode,
    genesisBlock,
    isGenesis,
    chooseBest,

    -- ** Header Store
    parentBlock,
    getParents,
    getAncestor,
    splitPoint,
    connectBlocks,
    connectBlock,
    blockLocator,

    -- ** Header Memory Store
    HeaderMemory (..),
    ShortBlockHash,
    BlockMap,
    shortBlockHash,
    initialChain,
    genesisMap,

    -- ** Helper Functions
    appendBlocks,
    validBlock,
    validCP,
    afterLastCP,
    bip34,
    validVersion,
    lastNoMinDiff,
    nextWorkRequired,
    nextEdaWorkRequired,
    nextDaaWorkRequired,
    nextAsertWorkRequired,
    computeAsertBits,
    computeTarget,
    getSuitableBlock,
    nextPowWorkRequired,
    calcNextWork,
    isValidPOW,
    blockPOW,
    headerWork,
    diffInterval,
    blockLocatorNodes,
    mineBlock,
    computeSubsidy,
    mtp,
    firstGreaterOrEqual,
    lastSmallerOrEqual,
  )
where

import Control.Applicative ((<|>))
import Control.DeepSeq
import Control.Monad (guard, mzero, unless, when)
import Control.Monad.Except (ExceptT (..), runExceptT, throwError)
import Control.Monad.State.Strict as State (StateT, get, gets, lift, modify)
import Control.Monad.Trans.Maybe
import Data.Binary (Binary (..))
import Data.Bits (shiftL, shiftR, (.&.))
import Data.ByteString qualified as B
import Data.ByteString.Short (ShortByteString, fromShort, toShort)
import Data.Bytes.Get
import Data.Bytes.Put
import Data.Bytes.Serial
import Data.Function (on)
import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as HashMap
import Data.Hashable
import Data.List (sort, sortBy)
import Data.Maybe (fromMaybe, listToMaybe)
import Data.Serialize (Serialize (..))
import Data.Typeable (Typeable)
import Data.Word (Word32, Word64)
import GHC.Generics (Generic)
import Haskoin.Block.Common
import Haskoin.Crypto
import Haskoin.Network.Data
import Haskoin.Transaction.Genesis
import Haskoin.Util

-- | Short version of the block hash. Uses the good end of the hash (the part
-- that doesn't have a long string of zeroes).
type ShortBlockHash = Word64

-- | Memory-based map to a serialized 'BlockNode' data structure.
-- 'ShortByteString' is used to avoid memory fragmentation and make the data
-- structure compact.
type BlockMap = HashMap ShortBlockHash ShortByteString

-- | Represents accumulated work in the block chain so far.
type BlockWork = Integer

-- | Data structure representing a block header and its position in the
-- block chain.
data BlockNode = BlockNode
  { header :: !BlockHeader,
    height :: !BlockHeight,
    -- | accumulated work so far
    work :: !BlockWork,
    -- | skip magic block hash
    skip :: !BlockHash
  }
  deriving (Show, Read, Generic, Hashable, NFData)

instance Serial BlockNode where
  deserialize = do
    header <- deserialize
    height <- getWord32le
    work <- getInteger
    if height == 0
      then do
        let skip = headerHash header
        return BlockNode {..}
      else do
        skip <- deserialize
        return BlockNode {..}
  serialize bn = do
    serialize $ bn.header
    putWord32le $ bn.height
    putInteger $ bn.work
    case bn.height of
      0 -> return ()
      _ -> serialize $ bn.skip

instance Serialize BlockNode where
  put = serialize
  get = deserialize

instance Binary BlockNode where
  put = serialize
  get = deserialize

instance Eq BlockNode where
  (==) = (==) `on` (.header)

instance Ord BlockNode where
  compare = compare `on` (.height)

-- | Memory-based header tree.
data HeaderMemory = HeaderMemory
  { blocks :: !BlockMap,
    best :: !BlockNode
  }
  deriving (Eq, Typeable, Show, Read, Generic, Hashable, NFData)

-- | Typeclass for block header chain storage monad.
class (Monad m) => BlockHeaders m where
  -- | Add a new 'BlockNode' to the chain. Does not validate.
  addBlockHeader :: BlockNode -> m ()

  -- | Get a 'BlockNode' associated with a 'BlockHash'.
  getBlockHeader :: BlockHash -> m (Maybe BlockNode)

  -- | Locate the 'BlockNode' for the highest block in the chain
  getBestBlockHeader :: m BlockNode

  -- | Set the highest block in the chain.
  setBestBlockHeader :: BlockNode -> m ()

  -- | Add a continuous bunch of block headers the chain. Does not validate.
  addBlockHeaders :: [BlockNode] -> m ()
  addBlockHeaders = mapM_ addBlockHeader

instance (Monad m) => BlockHeaders (StateT HeaderMemory m) where
  addBlockHeader = modify . addBlockHeaderMemory
  getBlockHeader bh = getBlockHeaderMemory bh <$> State.get
  getBestBlockHeader = gets (.best)
  setBestBlockHeader bn = modify $ \s -> s {best = bn}

-- | Initialize memory-based chain.
initialChain :: Network -> HeaderMemory
initialChain net =
  HeaderMemory
    { blocks = genesisMap net,
      best = genesisNode net
    }

-- | Initialize map for memory-based chain.
genesisMap :: Network -> BlockMap
genesisMap net =
  HashMap.singleton
    (shortBlockHash (headerHash net.genesisHeader))
    (toShort (runPutS (serialize (genesisNode net))))

-- | Add block header to memory block map.
addBlockHeaderMemory :: BlockNode -> HeaderMemory -> HeaderMemory
addBlockHeaderMemory bn s = s {blocks = addBlockToMap bn s.blocks}

-- | Get block header from memory block map.
getBlockHeaderMemory :: BlockHash -> HeaderMemory -> Maybe BlockNode
getBlockHeaderMemory bh s = do
  bs <- shortBlockHash bh `HashMap.lookup` s.blocks
  eitherToMaybe . runGetS deserialize $ fromShort bs

-- | Calculate short block hash taking eight non-zero bytes from the 16-byte
-- hash. This function will take the bytes that are not on the zero-side of the
-- hash, making colissions between short block hashes difficult.
shortBlockHash :: BlockHash -> ShortBlockHash
shortBlockHash =
  either error id . runGetS deserialize . B.take 8 . runPutS . serialize

-- | Add a block to memory-based block map.
addBlockToMap :: BlockNode -> BlockMap -> BlockMap
addBlockToMap node =
  HashMap.insert
    (shortBlockHash $ headerHash $ node.header)
    (toShort $ runPutS $ serialize node)

-- | Get the ancestor of the provided 'BlockNode' at the specified
-- 'BlockHeight'.
getAncestor ::
  (BlockHeaders m) =>
  BlockHeight ->
  BlockNode ->
  m (Maybe BlockNode)
getAncestor height node
  | height > node.height = return Nothing
  | otherwise = go node
  where
    e1 = error "Could not get current walk skip"
    e2 = error "Could not get previous walk skip"
    go walk
      | walk.height > height =
          let height_b = skipHeight (walk.height)
              height_a = skipHeight (walk.height - 1)
              not_genesis = not (isGenesis walk)
              is_b = height_b == height
              below_b = height_b > height
              at_or_below_a = height <= height_a
              far_enough = height_b - 2 > height_a && at_or_below_a
              recurse_b = below_b && not far_enough
              cond = not_genesis && (is_b || recurse_b)
           in if cond
                then do
                  walk' <- fromMaybe e1 <$> getBlockHeader walk.skip
                  go walk'
                else do
                  walk' <- fromMaybe e2 <$> getBlockHeader walk.header.prev
                  go walk'
      | otherwise = return $ Just walk

-- | Is the provided 'BlockNode' the Genesis block?
isGenesis :: BlockNode -> Bool
isGenesis BlockNode {height = 0} = True
isGenesis _ = False

-- | Build the genesis 'BlockNode' for the supplied 'Network'.
genesisNode :: Network -> BlockNode
genesisNode net =
  BlockNode
    { header = net.genesisHeader,
      height = 0,
      work = headerWork net.genesisHeader,
      skip = headerHash net.genesisHeader
    }

-- | Validate a list of continuous block headers and import them to the
-- block chain. Return 'Left' on failure with error information.
connectBlocks ::
  (BlockHeaders m) =>
  Network ->
  -- | current time
  Timestamp ->
  [BlockHeader] ->
  m (Either String [BlockNode])
connectBlocks _ _ [] = return $ Right []
connectBlocks net t bhs@(bh : _) =
  runExceptT $ do
    unless (chained bhs) $
      throwError "Blocks to connect do not form a chain"
    par <-
      maybeToExceptT
        "Could not get parent block"
        (MaybeT (parentBlock bh))
    pars <- lift $ getParents 10 par
    bb <- lift getBestBlockHeader
    go par [] bb par pars bhs >>= \case
      bns@(bn : _) -> do
        lift $ addBlockHeaders bns
        let bb' = chooseBest bn bb
        when (bb' /= bb) $ lift $ setBestBlockHeader bb'
        return bns
      _ -> undefined
  where
    chained (h1 : h2 : hs) = headerHash h1 == h2.prev && chained (h2 : hs)
    chained _ = True
    skipit lbh ls par
      | sh == lbh.height = return lbh
      | sh < lbh.height = do
          skM <- lift $ getAncestor sh lbh
          case skM of
            Just sk -> return sk
            Nothing ->
              throwError $
                "BUG: Could not get skip for block "
                  ++ show (headerHash $ par.header)
      | otherwise = do
          let sn = ls !! fromIntegral (par.height - sh)
          when (sn.height /= sh) $
            throwError "BUG: Node height not right in skip"
          return sn
      where
        sh = skipHeight (par.height + 1)
    go _ acc _ _ _ [] = return acc
    go lbh acc bb par pars (h : hs) = do
      sk <- skipit lbh acc par
      bn <- ExceptT . return $ validBlock net t bb par pars h sk
      go lbh (bn : acc) (chooseBest bn bb) bn (take 10 $ par : pars) hs

-- | Block's parent. If the block header is in the store, its parent must also
-- be there. No block header get deleted or pruned from the store.
parentBlock ::
  (BlockHeaders m) =>
  BlockHeader ->
  m (Maybe BlockNode)
parentBlock = getBlockHeader . (.prev)

-- | Validate and connect single block header to the block chain. Return 'Left'
-- if fails to be validated.
connectBlock ::
  (BlockHeaders m) =>
  Network ->
  -- | current time
  Timestamp ->
  BlockHeader ->
  m (Either String BlockNode)
connectBlock net t bh =
  runExceptT $ do
    par <-
      maybeToExceptT
        "Could not get parent block"
        (MaybeT (parentBlock bh))
    pars <- lift $ getParents 10 par
    skM <- lift $ getAncestor (skipHeight (par.height + 1)) par
    sk <-
      case skM of
        Just sk -> return sk
        Nothing ->
          throwError $
            "BUG: Could not get skip for block "
              ++ show (headerHash $ par.header)
    bb <- lift getBestBlockHeader
    bn <- ExceptT . return $ validBlock net t bb par pars bh sk
    let bb' = chooseBest bb bn
    lift $ addBlockHeader bn
    when (bb /= bb') . lift $ setBestBlockHeader bb'
    return bn

-- | Validate this block header. Build a 'BlockNode' if successful.
validBlock ::
  Network ->
  -- | current time
  Timestamp ->
  -- | best block
  BlockNode ->
  -- | immediate parent
  BlockNode ->
  -- | 10 parents above
  [BlockNode] ->
  -- | header to validate
  BlockHeader ->
  -- | skip node (black magic)
  BlockNode ->
  Either String BlockNode
validBlock net t bb par pars bh sk = do
  let mt = medianTime . map (.header.timestamp) $ par : pars
      nt = bh.timestamp
      hh = headerHash bh
      nv = bh.version
      ng = par.height + 1
      aw = par.work + headerWork bh
  unless (isValidPOW net bh) $
    Left $
      "Proof of work failed: " ++ show (headerHash bh)
  unless (nt <= t + 2 * 60 * 60) $
    Left $
      "Invalid header timestamp: " ++ show nt
  unless (nt >= mt) $
    Left $
      "Block timestamp too early: " ++ show nt
  unless (afterLastCP net (bb.height) ng) $
    Left $
      "Rewriting pre-checkpoint chain: " ++ show ng
  unless (validCP net ng hh) $
    Left $
      "Rejected checkpoint: " ++ show ng
  unless (bip34 net ng hh) $
    Left $
      "Rejected BIP-34 block: " ++ show hh
  unless (validVersion net ng nv) $
    Left $
      "Invalid block version: " ++ show nv
  return
    BlockNode
      { header = bh,
        height = ng,
        work = aw,
        skip = headerHash sk.header
      }

-- | Return the median of all provided timestamps. Can be unsorted. Error on
-- empty list.
medianTime :: [Timestamp] -> Timestamp
medianTime ts
  | null ts = error "Cannot compute median time of empty header list"
  | otherwise = sort ts !! (length ts `div` 2)

-- | Calculate the height of the skip (magic) block that corresponds to the
-- given height. The block hash of the ancestor at that height will be placed on
-- the 'BlockNode' structure to help locate ancestors at any height quickly.
skipHeight :: BlockHeight -> BlockHeight
skipHeight height
  | height < 2 = 0
  | height .&. 1 /= 0 = invertLowestOne (invertLowestOne $ height - 1) + 1
  | otherwise = invertLowestOne height

-- | Part of the skip black magic calculation.
invertLowestOne :: BlockHeight -> BlockHeight
invertLowestOne height = height .&. (height - 1)

-- | Get a number of parents for the provided block.
getParents ::
  (BlockHeaders m) =>
  Int ->
  BlockNode ->
  -- | starts from immediate parent
  m [BlockNode]
getParents = getpars []
  where
    getpars acc 0 _ = return $ reverse acc
    getpars acc n BlockNode {..}
      | height == 0 = return $ reverse acc
      | otherwise = do
          parM <- getBlockHeader header.prev
          case parM of
            Just bn -> getpars (bn : acc) (n - 1) bn
            Nothing -> error "BUG: All non-genesis blocks should have a parent"

-- | Verify that checkpoint location is valid.
validCP ::
  Network ->
  -- | new child height
  BlockHeight ->
  -- | new child hash
  BlockHash ->
  Bool
validCP net height newChildHash =
  case lookup height net.checkpoints of
    Just cpHash -> cpHash == newChildHash
    Nothing -> True

-- | New block height above the last checkpoint imported. Used to prevent a
-- reorg below the highest checkpoint that was already imported.
afterLastCP ::
  Network ->
  -- | best height
  BlockHeight ->
  -- | new imported block height
  BlockHeight ->
  Bool
afterLastCP net bestHeight newChildHeight =
  case lM of
    Just l -> l < newChildHeight
    Nothing -> True
  where
    lM =
      listToMaybe . reverse $
        [c | (c, _) <- net.checkpoints, c <= bestHeight]

-- | This block should be at least version 2 (BIP34). Block height must be
-- included in the coinbase transaction to prevent non-unique transaction
-- hashes.
bip34 ::
  Network ->
  -- | new child height
  BlockHeight ->
  -- | new child hash
  BlockHash ->
  Bool
bip34 net height hsh
  | fst net.bip34Block == 0 = True
  | fst net.bip34Block == height = snd net.bip34Block == hsh
  | otherwise = True

-- | Check if the provided block height and version are valid.
validVersion ::
  Network ->
  -- | new child height
  BlockHeight ->
  -- | new child version
  Word32 ->
  Bool
validVersion net height version
  | version < 2 = height < fst net.bip34Block
  | version < 3 = height < net.bip66Height
  | version < 4 = height < net.bip65Height
  | otherwise = True

-- | Find last block with normal, as opposed to minimum difficulty (for test
-- networks).
lastNoMinDiff :: (BlockHeaders m) => Network -> BlockNode -> m BlockNode
lastNoMinDiff _ bn@BlockNode {height = 0} = return bn
lastNoMinDiff net bn = do
  let i = bn.height `mod` diffInterval net /= 0
      c = encodeCompact net.powLimit
      l = bn.header.bits == c
      e1 =
        error $
          "Could not get block header for parent of "
            ++ show (headerHash bn.header)
  if i && l
    then do
      bn' <- fromMaybe e1 <$> getBlockHeader (bn.header.prev)
      lastNoMinDiff net bn'
    else return bn

-- | Returns the work required on a block header given the previous block. This
-- coresponds to @bitcoind@ function @GetNextWorkRequired@ in @main.cpp@.
nextWorkRequired ::
  (BlockHeaders m) =>
  Network ->
  BlockNode ->
  BlockHeader ->
  m Word32
nextWorkRequired net par bh = do
  ma <- getAsertAnchor net
  case asert ma <|> daa <|> eda <|> pow of
    Just f -> f par bh
    Nothing -> error "Could not determine difficulty algorithm"
  where
    asert ma = do
      anchor <- ma
      guard (par.height > anchor.height)
      return $ nextAsertWorkRequired net anchor
    daa = do
      daa_height <- net.daaHeight
      guard (par.height + 1 >= daa_height)
      return $ nextDaaWorkRequired net
    eda = do
      eda_height <- net.edaHeight
      guard (par.height + 1 >= eda_height)
      return $ nextEdaWorkRequired net
    pow = return $ nextPowWorkRequired net

-- | Find out the next amount of work required according to the Emergency
-- Difficulty Adjustment (EDA) algorithm from Bitcoin Cash.
nextEdaWorkRequired ::
  (BlockHeaders m) => Network -> BlockNode -> BlockHeader -> m Word32
nextEdaWorkRequired net par bh
  | par.height + 1 `mod` diffInterval net == 0 =
      nextWorkRequired net par bh
  | mindiff = return (encodeCompact net.powLimit)
  | par.header.bits == encodeCompact net.powLimit =
      return (encodeCompact net.powLimit)
  | otherwise = do
      par6 <- fromMaybe e1 <$> getAncestor (par.height - 6) par
      pars <- getParents 10 par
      pars6 <- getParents 10 par6
      let par6med =
            medianTime $ map (.header.timestamp) (par6 : pars6)
          parmed = medianTime $ map (.header.timestamp) (par : pars)
          mtp6 = parmed - par6med
      if mtp6 < 12 * 3600
        then return $ par.header.bits
        else
          return $
            let (diff, _) = decodeCompact par.header.bits
                ndiff = diff + (diff `shiftR` 2)
             in if net.powLimit > ndiff
                  then encodeCompact net.powLimit
                  else encodeCompact ndiff
  where
    mindiff = bh.timestamp > par.header.timestamp + net.targetSpacing * 2
    e1 = error "Could not get seventh ancestor of block"

-- | Find the next amount of work required according to the Difficulty
-- Adjustment Algorithm (DAA) from Bitcoin Cash.
nextDaaWorkRequired ::
  (BlockHeaders m) => Network -> BlockNode -> BlockHeader -> m Word32
nextDaaWorkRequired net par bh
  | mindiff = return (encodeCompact net.powLimit)
  | otherwise = do
      unless (par.height >= diffInterval net) $
        error "Block height below difficulty interval"
      l <- getSuitableBlock par
      par144 <- fromMaybe e1 <$> getAncestor (par.height - 144) par
      f <- getSuitableBlock par144
      let nextTarget = computeTarget net f l
      if nextTarget > net.powLimit
        then return $ encodeCompact net.powLimit
        else return $ encodeCompact nextTarget
  where
    e1 = error "Cannot get ancestor at parent - 144 height"
    mindiff = bh.timestamp > par.header.timestamp + net.targetSpacing * 2

mtp :: (BlockHeaders m) => BlockNode -> m Timestamp
mtp bn
  | bn.height == 0 = return 0
  | otherwise = do
      pars <- getParents 11 bn
      return $ medianTime (map (.header.timestamp) pars)

firstGreaterOrEqual ::
  (BlockHeaders m) =>
  Network ->
  (BlockNode -> m Ordering) ->
  m (Maybe BlockNode)
firstGreaterOrEqual = binSearch False

lastSmallerOrEqual ::
  (BlockHeaders m) =>
  Network ->
  (BlockNode -> m Ordering) ->
  m (Maybe BlockNode)
lastSmallerOrEqual = binSearch True

binSearch ::
  (BlockHeaders m) =>
  Bool ->
  Network ->
  (BlockNode -> m Ordering) ->
  m (Maybe BlockNode)
binSearch top net f = runMaybeT $ do
  (a, b) <- lift $ extremes net
  go a b
  where
    go a b = do
      m <- lift $ middleBlock a b
      a' <- lift $ f a
      b' <- lift $ f b
      m' <- lift $ f m
      r (a, a') (b, b') (m, m')
    r (a, a') (b, b') (m, m')
      | out_of_bounds a' b' = mzero
      | select_first a' = return a
      | select_last b' = return b
      | no_middle a b = choose_one a b
      | is_between a' m' = go a m
      | is_between m' b' = go m b
      | otherwise = mzero
    select_first a'
      | not top = a' /= LT
      | otherwise = False
    select_last b'
      | top = b' /= GT
      | otherwise = False
    out_of_bounds a' b'
      | top = a' == GT
      | otherwise = b' == LT
    no_middle a b = b.height - a.height <= 1
    is_between a' b' = a' /= GT && b' /= LT
    choose_one a b
      | top = return a
      | otherwise = return b

extremes :: (BlockHeaders m) => Network -> m (BlockNode, BlockNode)
extremes net = do
  b <- getBestBlockHeader
  return (genesisNode net, b)

middleBlock :: (BlockHeaders m) => BlockNode -> BlockNode -> m BlockNode
middleBlock a b =
  getAncestor h b >>= \case
    Nothing -> error "You fell into a pit full of mud and snakes"
    Just x -> return x
  where
    h = middleOf a.height b.height

middleOf :: (Integral a) => a -> a -> a
middleOf a b = a + ((b - a) `div` 2)

-- TODO: Use known anchor after fork
getAsertAnchor :: (BlockHeaders m) => Network -> m (Maybe BlockNode)
getAsertAnchor net =
  case net.asertActivationTime of
    Nothing -> return Nothing
    Just act -> firstGreaterOrEqual net (f act)
  where
    f act bn = do
      m <- mtp bn
      return $ compare m act

-- | Find the next amount of work required according to the aserti3-2d algorithm.
nextAsertWorkRequired ::
  (BlockHeaders m) =>
  Network ->
  BlockNode ->
  BlockNode ->
  BlockHeader ->
  m Word32
nextAsertWorkRequired net anchor par bh = do
  anchor_parent <-
    fromMaybe e_fork <$> getBlockHeader anchor.header.prev
  let anchor_parent_time = toInteger anchor_parent.header.timestamp
      time_diff = current_time - anchor_parent_time
  return $ computeAsertBits halflife anchor_bits time_diff height_diff
  where
    halflife = net.asertHalfLife
    anchor_height = toInteger anchor.height
    anchor_bits = anchor.header.bits
    current_height = toInteger par.height + 1
    height_diff = current_height - anchor_height
    current_time = toInteger bh.timestamp
    e_fork = error "Could not get fork block header"

idealBlockTime :: Integer
idealBlockTime = 10 * 60

rBits :: Int
rBits = 16

radix :: Integer
radix = 1 `shiftL` rBits

maxBits :: Word32
maxBits = 0x1d00ffff

maxTarget :: Integer
maxTarget = fst $ decodeCompact maxBits

computeAsertBits ::
  Integer ->
  Word32 ->
  Integer ->
  Integer ->
  Word32
computeAsertBits halflife anchor_bits time_diff height_diff =
  if e2 >= 0 && e2 < 65536
    then
      if g4 == 0
        then encodeCompact 1
        else
          if g4 > maxTarget
            then maxBits
            else encodeCompact g4
    else error $ "Exponent not in range: " ++ show e2
  where
    g1 = fst (decodeCompact anchor_bits)
    e1 =
      ((time_diff - idealBlockTime * (height_diff + 1)) * radix)
        `quot` halflife
    s = e1 `shiftR` rBits
    e2 = e1 - s * radix
    g2 =
      g1
        * ( radix
              + ( (195766423245049 * e2 + 971821376 * e2 ^ 2 + 5127 * e2 ^ 3 + 2 ^ 47)
                    `shiftR` (rBits * 3)
                )
          )
    g3 =
      if s < 0
        then g2 `shiftR` negate (fromIntegral s)
        else g2 `shiftL` fromIntegral s
    g4 = g3 `shiftR` rBits

-- | Compute Bitcoin Cash DAA target for a new block.
computeTarget :: Network -> BlockNode -> BlockNode -> Integer
computeTarget net f l =
  let work = (l.work - f.work) * fromIntegral net.targetSpacing
      tspan = l.header.timestamp - f.header.timestamp
      tspan'
        | tspan > 288 * net.targetSpacing =
            288 * net.targetSpacing
        | tspan < 72 * net.targetSpacing =
            72 * net.targetSpacing
        | otherwise = tspan
      work' = work `div` fromIntegral tspan'
   in 2 ^ (256 :: Integer) `div` work'

-- | Get suitable block for Bitcoin Cash DAA computation.
getSuitableBlock :: (BlockHeaders m) => BlockNode -> m BlockNode
getSuitableBlock par = do
  unless (par.height >= 3) $ error "Block height is less than three"
  blocks <- (par :) <$> getParents 2 par
  return $ sortBy (compare `on` (.header.timestamp)) blocks !! 1

-- | Returns the work required on a block header given the previous block. This
-- coresponds to bitcoind function GetNextWorkRequired in main.cpp.
nextPowWorkRequired ::
  (BlockHeaders m) => Network -> BlockNode -> BlockHeader -> m Word32
nextPowWorkRequired net par bh
  | par.height + 1 `mod` diffInterval net /= 0 =
      if net.minDiffBlocks
        then
          if ht > pt + delta
            then return $ encodeCompact net.powLimit
            else do
              d <- lastNoMinDiff net par
              return d.header.bits
        else return par.header.bits
  | otherwise = do
      let rh = par.height - diffInterval net - 1
      a <- fromMaybe e1 <$> getAncestor rh par
      let t = a.header.timestamp
      return $ calcNextWork net par.header t
  where
    e1 = error "Could not get ancestor for block header"
    pt = par.header.timestamp
    ht = bh.timestamp
    delta = net.targetSpacing * 2

-- | Computes the work required for the first block in a new retarget period.
calcNextWork ::
  Network ->
  -- | last block in previous retarget (parent)
  BlockHeader ->
  -- | timestamp of first block in previous retarget
  Timestamp ->
  Word32
calcNextWork net header time
  | net.powNoRetarget = header.bits
  | new > net.powLimit = encodeCompact net.powLimit
  | otherwise = encodeCompact new
  where
    s = header.timestamp - time
    n
      | s < net.targetTimespan `div` 4 = net.targetTimespan `div` 4
      | s > net.targetTimespan * 4 = net.targetTimespan * 4
      | otherwise = s
    l = fst $ decodeCompact header.bits
    new = l * fromIntegral n `div` fromIntegral net.targetTimespan

-- | Returns True if the difficulty target (bits) of the header is valid and the
-- proof of work of the header matches the advertised difficulty target. This
-- function corresponds to the function @CheckProofOfWork@ from @bitcoind@ in
-- @main.cpp@.
isValidPOW :: Network -> BlockHeader -> Bool
isValidPOW net h
  | target <= 0 || over || target > net.powLimit = False
  | otherwise = blockPOW (headerHash h) <= fromIntegral target
  where
    (target, over) = decodeCompact h.bits

-- | Returns the proof of work of a block header hash as an 'Integer' number.
blockPOW :: BlockHash -> Integer
blockPOW = bsToInteger . B.reverse . runPutS . serialize

-- | Returns the work represented by this block. Work is defined as the number
-- of tries needed to solve a block in the average case with respect to the
-- target.
headerWork :: BlockHeader -> Integer
headerWork bh = largestHash `div` (target + 1)
  where
    target = fst $ decodeCompact bh.bits
    largestHash = 1 `shiftL` 256

-- | Number of blocks on average between difficulty cycles (2016 blocks).
diffInterval :: Network -> Word32
diffInterval net = net.targetTimespan `div` net.targetSpacing

-- | Compare two blocks to get the best.
chooseBest :: BlockNode -> BlockNode -> BlockNode
chooseBest b1 b2
  | b1.work == b2.work =
      if b1.height >= b2.height
        then b1
        else b2
  | b1.work > b2.work = b1
  | otherwise = b2

-- | Get list of blocks for a block locator.
blockLocatorNodes :: (BlockHeaders m) => BlockNode -> m [BlockNode]
blockLocatorNodes best =
  reverse <$> go [] best 1
  where
    e1 = error "Could not get ancestor"
    go loc bn n =
      let loc' = bn : loc
          n' =
            if length loc' > 10
              then n * 2
              else 1
       in if bn.height < n'
            then do
              a <- fromMaybe e1 <$> getAncestor 0 bn
              return $ a : loc'
            else do
              let h = bn.height - n'
              bn' <- fromMaybe e1 <$> getAncestor h bn
              go loc' bn' n'

-- | Get block locator.
blockLocator :: (BlockHeaders m) => BlockNode -> m BlockLocator
blockLocator bn = map (headerHash . (.header)) <$> blockLocatorNodes bn

-- | Become rich beyond your wildest dreams.
mineBlock :: Network -> Word32 -> BlockHeader -> BlockHeader
mineBlock net seed h =
  head
    [ j
      | i <- (+ seed) <$> [0 .. maxBound],
        let j = h {nonce = i},
        isValidPOW net j
    ]

-- | Generate and append new blocks (mining). Only practical in regtest network.
appendBlocks ::
  Network ->
  -- | random seed
  Word32 ->
  BlockHeader ->
  Int ->
  [BlockHeader]
appendBlocks _ _ _ 0 = []
appendBlocks net seed bh i =
  bh' : appendBlocks net seed bh' (i - 1)
  where
    bh' =
      mineBlock
        net
        seed
        bh
          { prev = headerHash bh,
            -- Just to make it different in every header
            merkle = sha256 $ runPutS $ serialize seed
          }

-- | Find the last common block ancestor between provided block headers.
splitPoint :: (BlockHeaders m) => BlockNode -> BlockNode -> m BlockNode
splitPoint l r = do
  let h = min l.height r.height
  ll <- fromMaybe e <$> getAncestor h l
  lr <- fromMaybe e <$> getAncestor h r
  f ll lr
  where
    e = error "BUG: Could not get ancestor at lowest height"
    f ll lr =
      if ll == lr
        then return lr
        else do
          let h = ll.height - 1
          pl <- fromMaybe e <$> getAncestor h ll
          pr <- fromMaybe e <$> getAncestor h lr
          f pl pr

-- | Generate the entire Genesis block for 'Network'.
genesisBlock :: Network -> Ctx -> Block
genesisBlock net ctx = Block net.genesisHeader [genesisTx ctx]

-- | Compute block subsidy at particular height.
computeSubsidy :: Network -> BlockHeight -> Word64
computeSubsidy net height =
  let halvings = height `div` net.halvingInterval
      ini = 50 * 100 * 1000 * 1000
   in if halvings >= 64
        then 0
        else ini `shiftR` fromIntegral halvings