{-# 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
  { BlockNode -> BlockHeader
header :: !BlockHeader,
    BlockNode -> BlockHeight
height :: !BlockHeight,
    -- | accumulated work so far
    BlockNode -> BlockWork
work :: !BlockWork,
    -- | skip magic block hash
    BlockNode -> BlockHash
skip :: !BlockHash
  }
  deriving (Int -> BlockNode -> ShowS
[BlockNode] -> ShowS
BlockNode -> String
(Int -> BlockNode -> ShowS)
-> (BlockNode -> String)
-> ([BlockNode] -> ShowS)
-> Show BlockNode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BlockNode -> ShowS
showsPrec :: Int -> BlockNode -> ShowS
$cshow :: BlockNode -> String
show :: BlockNode -> String
$cshowList :: [BlockNode] -> ShowS
showList :: [BlockNode] -> ShowS
Show, ReadPrec [BlockNode]
ReadPrec BlockNode
Int -> ReadS BlockNode
ReadS [BlockNode]
(Int -> ReadS BlockNode)
-> ReadS [BlockNode]
-> ReadPrec BlockNode
-> ReadPrec [BlockNode]
-> Read BlockNode
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS BlockNode
readsPrec :: Int -> ReadS BlockNode
$creadList :: ReadS [BlockNode]
readList :: ReadS [BlockNode]
$creadPrec :: ReadPrec BlockNode
readPrec :: ReadPrec BlockNode
$creadListPrec :: ReadPrec [BlockNode]
readListPrec :: ReadPrec [BlockNode]
Read, (forall x. BlockNode -> Rep BlockNode x)
-> (forall x. Rep BlockNode x -> BlockNode) -> Generic BlockNode
forall x. Rep BlockNode x -> BlockNode
forall x. BlockNode -> Rep BlockNode x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. BlockNode -> Rep BlockNode x
from :: forall x. BlockNode -> Rep BlockNode x
$cto :: forall x. Rep BlockNode x -> BlockNode
to :: forall x. Rep BlockNode x -> BlockNode
Generic, Eq BlockNode
Eq BlockNode =>
(Int -> BlockNode -> Int)
-> (BlockNode -> Int) -> Hashable BlockNode
Int -> BlockNode -> Int
BlockNode -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
$chashWithSalt :: Int -> BlockNode -> Int
hashWithSalt :: Int -> BlockNode -> Int
$chash :: BlockNode -> Int
hash :: BlockNode -> Int
Hashable, BlockNode -> ()
(BlockNode -> ()) -> NFData BlockNode
forall a. (a -> ()) -> NFData a
$crnf :: BlockNode -> ()
rnf :: BlockNode -> ()
NFData)

instance Serial BlockNode where
  deserialize :: forall (m :: * -> *). MonadGet m => m BlockNode
deserialize = do
    BlockHeader
header <- m BlockHeader
forall a (m :: * -> *). (Serial a, MonadGet m) => m a
forall (m :: * -> *). MonadGet m => m BlockHeader
deserialize
    BlockHeight
height <- m BlockHeight
forall (m :: * -> *). MonadGet m => m BlockHeight
getWord32le
    BlockWork
work <- m BlockWork
forall (m :: * -> *). MonadGet m => m BlockWork
getInteger
    if BlockHeight
height BlockHeight -> BlockHeight -> Bool
forall a. Eq a => a -> a -> Bool
== BlockHeight
0
      then do
        let skip :: BlockHash
skip = BlockHeader -> BlockHash
headerHash BlockHeader
header
        BlockNode -> m BlockNode
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return BlockNode {BlockWork
BlockHeight
BlockHeader
BlockHash
$sel:header:BlockNode :: BlockHeader
$sel:height:BlockNode :: BlockHeight
$sel:work:BlockNode :: BlockWork
$sel:skip:BlockNode :: BlockHash
header :: BlockHeader
height :: BlockHeight
work :: BlockWork
skip :: BlockHash
..}
      else do
        BlockHash
skip <- m BlockHash
forall a (m :: * -> *). (Serial a, MonadGet m) => m a
forall (m :: * -> *). MonadGet m => m BlockHash
deserialize
        BlockNode -> m BlockNode
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return BlockNode {BlockWork
BlockHeight
BlockHeader
BlockHash
$sel:header:BlockNode :: BlockHeader
$sel:height:BlockNode :: BlockHeight
$sel:work:BlockNode :: BlockWork
$sel:skip:BlockNode :: BlockHash
header :: BlockHeader
height :: BlockHeight
work :: BlockWork
skip :: BlockHash
..}
  serialize :: forall (m :: * -> *). MonadPut m => BlockNode -> m ()
serialize BlockNode
bn = do
    BlockHeader -> m ()
forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
forall (m :: * -> *). MonadPut m => BlockHeader -> m ()
serialize (BlockHeader -> m ()) -> BlockHeader -> m ()
forall a b. (a -> b) -> a -> b
$ BlockNode
bn.header
    BlockHeight -> m ()
forall (m :: * -> *). MonadPut m => BlockHeight -> m ()
putWord32le (BlockHeight -> m ()) -> BlockHeight -> m ()
forall a b. (a -> b) -> a -> b
$ BlockNode
bn.height
    BlockWork -> m ()
forall (m :: * -> *). MonadPut m => BlockWork -> m ()
putInteger (BlockWork -> m ()) -> BlockWork -> m ()
forall a b. (a -> b) -> a -> b
$ BlockNode
bn.work
    case BlockNode
bn.height of
      BlockHeight
0 -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      BlockHeight
_ -> BlockHash -> m ()
forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
forall (m :: * -> *). MonadPut m => BlockHash -> m ()
serialize (BlockHash -> m ()) -> BlockHash -> m ()
forall a b. (a -> b) -> a -> b
$ BlockNode
bn.skip

instance Serialize BlockNode where
  put :: Putter BlockNode
put = Putter BlockNode
forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
forall (m :: * -> *). MonadPut m => BlockNode -> m ()
serialize
  get :: Get BlockNode
get = Get BlockNode
forall a (m :: * -> *). (Serial a, MonadGet m) => m a
forall (m :: * -> *). MonadGet m => m BlockNode
deserialize

instance Binary BlockNode where
  put :: BlockNode -> Put
put = BlockNode -> Put
forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
forall (m :: * -> *). MonadPut m => BlockNode -> m ()
serialize
  get :: Get BlockNode
get = Get BlockNode
forall a (m :: * -> *). (Serial a, MonadGet m) => m a
forall (m :: * -> *). MonadGet m => m BlockNode
deserialize

instance Eq BlockNode where
  == :: BlockNode -> BlockNode -> Bool
(==) = BlockHeader -> BlockHeader -> Bool
forall a. Eq a => a -> a -> Bool
(==) (BlockHeader -> BlockHeader -> Bool)
-> (BlockNode -> BlockHeader) -> BlockNode -> BlockNode -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (.header)

instance Ord BlockNode where
  compare :: BlockNode -> BlockNode -> Ordering
compare = BlockHeight -> BlockHeight -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (BlockHeight -> BlockHeight -> Ordering)
-> (BlockNode -> BlockHeight) -> BlockNode -> BlockNode -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (.height)

-- | Memory-based header tree.
data HeaderMemory = HeaderMemory
  { HeaderMemory -> HashMap Word64 ShortByteString
blocks :: !BlockMap,
    HeaderMemory -> BlockNode
best :: !BlockNode
  }
  deriving (HeaderMemory -> HeaderMemory -> Bool
(HeaderMemory -> HeaderMemory -> Bool)
-> (HeaderMemory -> HeaderMemory -> Bool) -> Eq HeaderMemory
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HeaderMemory -> HeaderMemory -> Bool
== :: HeaderMemory -> HeaderMemory -> Bool
$c/= :: HeaderMemory -> HeaderMemory -> Bool
/= :: HeaderMemory -> HeaderMemory -> Bool
Eq, Typeable, Int -> HeaderMemory -> ShowS
[HeaderMemory] -> ShowS
HeaderMemory -> String
(Int -> HeaderMemory -> ShowS)
-> (HeaderMemory -> String)
-> ([HeaderMemory] -> ShowS)
-> Show HeaderMemory
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HeaderMemory -> ShowS
showsPrec :: Int -> HeaderMemory -> ShowS
$cshow :: HeaderMemory -> String
show :: HeaderMemory -> String
$cshowList :: [HeaderMemory] -> ShowS
showList :: [HeaderMemory] -> ShowS
Show, ReadPrec [HeaderMemory]
ReadPrec HeaderMemory
Int -> ReadS HeaderMemory
ReadS [HeaderMemory]
(Int -> ReadS HeaderMemory)
-> ReadS [HeaderMemory]
-> ReadPrec HeaderMemory
-> ReadPrec [HeaderMemory]
-> Read HeaderMemory
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS HeaderMemory
readsPrec :: Int -> ReadS HeaderMemory
$creadList :: ReadS [HeaderMemory]
readList :: ReadS [HeaderMemory]
$creadPrec :: ReadPrec HeaderMemory
readPrec :: ReadPrec HeaderMemory
$creadListPrec :: ReadPrec [HeaderMemory]
readListPrec :: ReadPrec [HeaderMemory]
Read, (forall x. HeaderMemory -> Rep HeaderMemory x)
-> (forall x. Rep HeaderMemory x -> HeaderMemory)
-> Generic HeaderMemory
forall x. Rep HeaderMemory x -> HeaderMemory
forall x. HeaderMemory -> Rep HeaderMemory x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. HeaderMemory -> Rep HeaderMemory x
from :: forall x. HeaderMemory -> Rep HeaderMemory x
$cto :: forall x. Rep HeaderMemory x -> HeaderMemory
to :: forall x. Rep HeaderMemory x -> HeaderMemory
Generic, Eq HeaderMemory
Eq HeaderMemory =>
(Int -> HeaderMemory -> Int)
-> (HeaderMemory -> Int) -> Hashable HeaderMemory
Int -> HeaderMemory -> Int
HeaderMemory -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
$chashWithSalt :: Int -> HeaderMemory -> Int
hashWithSalt :: Int -> HeaderMemory -> Int
$chash :: HeaderMemory -> Int
hash :: HeaderMemory -> Int
Hashable, HeaderMemory -> ()
(HeaderMemory -> ()) -> NFData HeaderMemory
forall a. (a -> ()) -> NFData a
$crnf :: HeaderMemory -> ()
rnf :: HeaderMemory -> ()
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 = (BlockNode -> m ()) -> [BlockNode] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ BlockNode -> m ()
forall (m :: * -> *). BlockHeaders m => BlockNode -> m ()
addBlockHeader

instance (Monad m) => BlockHeaders (StateT HeaderMemory m) where
  addBlockHeader :: BlockNode -> StateT HeaderMemory m ()
addBlockHeader = (HeaderMemory -> HeaderMemory) -> StateT HeaderMemory m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((HeaderMemory -> HeaderMemory) -> StateT HeaderMemory m ())
-> (BlockNode -> HeaderMemory -> HeaderMemory)
-> BlockNode
-> StateT HeaderMemory m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockNode -> HeaderMemory -> HeaderMemory
addBlockHeaderMemory
  getBlockHeader :: BlockHash -> StateT HeaderMemory m (Maybe BlockNode)
getBlockHeader BlockHash
bh = BlockHash -> HeaderMemory -> Maybe BlockNode
getBlockHeaderMemory BlockHash
bh (HeaderMemory -> Maybe BlockNode)
-> StateT HeaderMemory m HeaderMemory
-> StateT HeaderMemory m (Maybe BlockNode)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT HeaderMemory m HeaderMemory
forall s (m :: * -> *). MonadState s m => m s
State.get
  getBestBlockHeader :: StateT HeaderMemory m BlockNode
getBestBlockHeader = (HeaderMemory -> BlockNode) -> StateT HeaderMemory m BlockNode
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (.best)
  setBestBlockHeader :: BlockNode -> StateT HeaderMemory m ()
setBestBlockHeader BlockNode
bn = (HeaderMemory -> HeaderMemory) -> StateT HeaderMemory m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((HeaderMemory -> HeaderMemory) -> StateT HeaderMemory m ())
-> (HeaderMemory -> HeaderMemory) -> StateT HeaderMemory m ()
forall a b. (a -> b) -> a -> b
$ \HeaderMemory
s -> HeaderMemory
s {best = bn}

-- | Initialize memory-based chain.
initialChain :: Network -> HeaderMemory
initialChain :: Network -> HeaderMemory
initialChain Network
net =
  HeaderMemory
    { $sel:blocks:HeaderMemory :: HashMap Word64 ShortByteString
blocks = Network -> HashMap Word64 ShortByteString
genesisMap Network
net,
      $sel:best:HeaderMemory :: BlockNode
best = Network -> BlockNode
genesisNode Network
net
    }

-- | Initialize map for memory-based chain.
genesisMap :: Network -> BlockMap
genesisMap :: Network -> HashMap Word64 ShortByteString
genesisMap Network
net =
  Word64 -> ShortByteString -> HashMap Word64 ShortByteString
forall k v. Hashable k => k -> v -> HashMap k v
HashMap.singleton
    (BlockHash -> Word64
shortBlockHash (BlockHeader -> BlockHash
headerHash Network
net.genesisHeader))
    (ByteString -> ShortByteString
toShort (Put -> ByteString
runPutS (Putter BlockNode
forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
forall (m :: * -> *). MonadPut m => BlockNode -> m ()
serialize (Network -> BlockNode
genesisNode Network
net))))

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

-- | Get block header from memory block map.
getBlockHeaderMemory :: BlockHash -> HeaderMemory -> Maybe BlockNode
getBlockHeaderMemory :: BlockHash -> HeaderMemory -> Maybe BlockNode
getBlockHeaderMemory BlockHash
bh HeaderMemory
s = do
  ShortByteString
bs <- BlockHash -> Word64
shortBlockHash BlockHash
bh Word64 -> HashMap Word64 ShortByteString -> Maybe ShortByteString
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
`HashMap.lookup` HeaderMemory
s.blocks
  Either String BlockNode -> Maybe BlockNode
forall a b. Either a b -> Maybe b
eitherToMaybe (Either String BlockNode -> Maybe BlockNode)
-> (ByteString -> Either String BlockNode)
-> ByteString
-> Maybe BlockNode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Get BlockNode -> ByteString -> Either String BlockNode
forall a. Get a -> ByteString -> Either String a
runGetS Get BlockNode
forall a (m :: * -> *). (Serial a, MonadGet m) => m a
forall (m :: * -> *). MonadGet m => m BlockNode
deserialize (ByteString -> Maybe BlockNode) -> ByteString -> Maybe BlockNode
forall a b. (a -> b) -> a -> b
$ ShortByteString -> ByteString
fromShort ShortByteString
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 :: BlockHash -> Word64
shortBlockHash =
  (String -> Word64)
-> (Word64 -> Word64) -> Either String Word64 -> Word64
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Word64
forall a. HasCallStack => String -> a
error Word64 -> Word64
forall a. a -> a
id (Either String Word64 -> Word64)
-> (BlockHash -> Either String Word64) -> BlockHash -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Get Word64 -> ByteString -> Either String Word64
forall a. Get a -> ByteString -> Either String a
runGetS Get Word64
forall a (m :: * -> *). (Serial a, MonadGet m) => m a
forall (m :: * -> *). MonadGet m => m Word64
deserialize (ByteString -> Either String Word64)
-> (BlockHash -> ByteString) -> BlockHash -> Either String Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByteString -> ByteString
B.take Int
8 (ByteString -> ByteString)
-> (BlockHash -> ByteString) -> BlockHash -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Put -> ByteString
runPutS (Put -> ByteString)
-> (BlockHash -> Put) -> BlockHash -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockHash -> Put
forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
forall (m :: * -> *). MonadPut m => BlockHash -> m ()
serialize

-- | Add a block to memory-based block map.
addBlockToMap :: BlockNode -> BlockMap -> BlockMap
addBlockToMap :: BlockNode
-> HashMap Word64 ShortByteString -> HashMap Word64 ShortByteString
addBlockToMap BlockNode
node =
  Word64
-> ShortByteString
-> HashMap Word64 ShortByteString
-> HashMap Word64 ShortByteString
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert
    (BlockHash -> Word64
shortBlockHash (BlockHash -> Word64) -> BlockHash -> Word64
forall a b. (a -> b) -> a -> b
$ BlockHeader -> BlockHash
headerHash (BlockHeader -> BlockHash) -> BlockHeader -> BlockHash
forall a b. (a -> b) -> a -> b
$ BlockNode
node.header)
    (ByteString -> ShortByteString
toShort (ByteString -> ShortByteString) -> ByteString -> ShortByteString
forall a b. (a -> b) -> a -> b
$ Put -> ByteString
runPutS (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$ Putter BlockNode
forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
forall (m :: * -> *). MonadPut m => BlockNode -> m ()
serialize BlockNode
node)

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

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

-- | Build the genesis 'BlockNode' for the supplied 'Network'.
genesisNode :: Network -> BlockNode
genesisNode :: Network -> BlockNode
genesisNode Network
net =
  BlockNode
    { $sel:header:BlockNode :: BlockHeader
header = Network
net.genesisHeader,
      $sel:height:BlockNode :: BlockHeight
height = BlockHeight
0,
      $sel:work:BlockNode :: BlockWork
work = BlockHeader -> BlockWork
headerWork Network
net.genesisHeader,
      $sel:skip:BlockNode :: BlockHash
skip = BlockHeader -> BlockHash
headerHash Network
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 :: forall (m :: * -> *).
BlockHeaders m =>
Network
-> BlockHeight -> [BlockHeader] -> m (Either String [BlockNode])
connectBlocks Network
_ BlockHeight
_ [] = Either String [BlockNode] -> m (Either String [BlockNode])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String [BlockNode] -> m (Either String [BlockNode]))
-> Either String [BlockNode] -> m (Either String [BlockNode])
forall a b. (a -> b) -> a -> b
$ [BlockNode] -> Either String [BlockNode]
forall a b. b -> Either a b
Right []
connectBlocks Network
net BlockHeight
t bhs :: [BlockHeader]
bhs@(BlockHeader
bh : [BlockHeader]
_) =
  ExceptT String m [BlockNode] -> m (Either String [BlockNode])
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT String m [BlockNode] -> m (Either String [BlockNode]))
-> ExceptT String m [BlockNode] -> m (Either String [BlockNode])
forall a b. (a -> b) -> a -> b
$ do
    Bool -> ExceptT String m () -> ExceptT String m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([BlockHeader] -> Bool
chained [BlockHeader]
bhs) (ExceptT String m () -> ExceptT String m ())
-> ExceptT String m () -> ExceptT String m ()
forall a b. (a -> b) -> a -> b
$
      String -> ExceptT String m ()
forall a. String -> ExceptT String m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"Blocks to connect do not form a chain"
    BlockNode
par <-
      String -> MaybeT m BlockNode -> ExceptT String m BlockNode
forall (m :: * -> *) e a.
Functor m =>
e -> MaybeT m a -> ExceptT e m a
maybeToExceptT
        String
"Could not get parent block"
        (m (Maybe BlockNode) -> MaybeT m BlockNode
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (BlockHeader -> m (Maybe BlockNode)
forall (m :: * -> *).
BlockHeaders m =>
BlockHeader -> m (Maybe BlockNode)
parentBlock BlockHeader
bh))
    [BlockNode]
pars <- m [BlockNode] -> ExceptT String m [BlockNode]
forall (m :: * -> *) a. Monad m => m a -> ExceptT String m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [BlockNode] -> ExceptT String m [BlockNode])
-> m [BlockNode] -> ExceptT String m [BlockNode]
forall a b. (a -> b) -> a -> b
$ Int -> BlockNode -> m [BlockNode]
forall (m :: * -> *).
BlockHeaders m =>
Int -> BlockNode -> m [BlockNode]
getParents Int
10 BlockNode
par
    BlockNode
bb <- m BlockNode -> ExceptT String m BlockNode
forall (m :: * -> *) a. Monad m => m a -> ExceptT String m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m BlockNode
forall (m :: * -> *). BlockHeaders m => m BlockNode
getBestBlockHeader
    BlockNode
-> [BlockNode]
-> BlockNode
-> BlockNode
-> [BlockNode]
-> [BlockHeader]
-> ExceptT String m [BlockNode]
forall {m :: * -> *}.
BlockHeaders m =>
BlockNode
-> [BlockNode]
-> BlockNode
-> BlockNode
-> [BlockNode]
-> [BlockHeader]
-> ExceptT String m [BlockNode]
go BlockNode
par [] BlockNode
bb BlockNode
par [BlockNode]
pars [BlockHeader]
bhs ExceptT String m [BlockNode]
-> ([BlockNode] -> ExceptT String m [BlockNode])
-> ExceptT String m [BlockNode]
forall a b.
ExceptT String m a
-> (a -> ExceptT String m b) -> ExceptT String m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      bns :: [BlockNode]
bns@(BlockNode
bn : [BlockNode]
_) -> do
        m () -> ExceptT String m ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT String m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ExceptT String m ()) -> m () -> ExceptT String m ()
forall a b. (a -> b) -> a -> b
$ [BlockNode] -> m ()
forall (m :: * -> *). BlockHeaders m => [BlockNode] -> m ()
addBlockHeaders [BlockNode]
bns
        let bb' :: BlockNode
bb' = BlockNode -> BlockNode -> BlockNode
chooseBest BlockNode
bn BlockNode
bb
        Bool -> ExceptT String m () -> ExceptT String m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BlockNode
bb' BlockNode -> BlockNode -> Bool
forall a. Eq a => a -> a -> Bool
/= BlockNode
bb) (ExceptT String m () -> ExceptT String m ())
-> ExceptT String m () -> ExceptT String m ()
forall a b. (a -> b) -> a -> b
$ m () -> ExceptT String m ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT String m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ExceptT String m ()) -> m () -> ExceptT String m ()
forall a b. (a -> b) -> a -> b
$ BlockNode -> m ()
forall (m :: * -> *). BlockHeaders m => BlockNode -> m ()
setBestBlockHeader BlockNode
bb'
        [BlockNode] -> ExceptT String m [BlockNode]
forall a. a -> ExceptT String m a
forall (m :: * -> *) a. Monad m => a -> m a
return [BlockNode]
bns
      [BlockNode]
_ -> ExceptT String m [BlockNode]
forall a. HasCallStack => a
undefined
  where
    chained :: [BlockHeader] -> Bool
chained (BlockHeader
h1 : BlockHeader
h2 : [BlockHeader]
hs) = BlockHeader -> BlockHash
headerHash BlockHeader
h1 BlockHash -> BlockHash -> Bool
forall a. Eq a => a -> a -> Bool
== BlockHeader
h2.prev Bool -> Bool -> Bool
&& [BlockHeader] -> Bool
chained (BlockHeader
h2 BlockHeader -> [BlockHeader] -> [BlockHeader]
forall a. a -> [a] -> [a]
: [BlockHeader]
hs)
    chained [BlockHeader]
_ = Bool
True
    skipit :: BlockNode -> [BlockNode] -> r -> t m BlockNode
skipit BlockNode
lbh [BlockNode]
ls r
par
      | BlockHeight
sh BlockHeight -> BlockHeight -> Bool
forall a. Eq a => a -> a -> Bool
== BlockNode
lbh.height = BlockNode -> t m BlockNode
forall a. a -> t m a
forall (m :: * -> *) a. Monad m => a -> m a
return BlockNode
lbh
      | BlockHeight
sh BlockHeight -> BlockHeight -> Bool
forall a. Ord a => a -> a -> Bool
< BlockNode
lbh.height = do
          Maybe BlockNode
skM <- m (Maybe BlockNode) -> t m (Maybe BlockNode)
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Maybe BlockNode) -> t m (Maybe BlockNode))
-> m (Maybe BlockNode) -> t m (Maybe BlockNode)
forall a b. (a -> b) -> a -> b
$ BlockHeight -> BlockNode -> m (Maybe BlockNode)
forall (m :: * -> *).
BlockHeaders m =>
BlockHeight -> BlockNode -> m (Maybe BlockNode)
getAncestor BlockHeight
sh BlockNode
lbh
          case Maybe BlockNode
skM of
            Just BlockNode
sk -> BlockNode -> t m BlockNode
forall a. a -> t m a
forall (m :: * -> *) a. Monad m => a -> m a
return BlockNode
sk
            Maybe BlockNode
Nothing ->
              String -> t m BlockNode
forall a. String -> t m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> t m BlockNode) -> String -> t m BlockNode
forall a b. (a -> b) -> a -> b
$
                String
"BUG: Could not get skip for block "
                  String -> ShowS
forall a. [a] -> [a] -> [a]
++ BlockHash -> String
forall a. Show a => a -> String
show (BlockHeader -> BlockHash
headerHash (BlockHeader -> BlockHash) -> BlockHeader -> BlockHash
forall a b. (a -> b) -> a -> b
$ r
par.header)
      | Bool
otherwise = do
          let sn :: BlockNode
sn = [BlockNode]
ls [BlockNode] -> Int -> BlockNode
forall a. HasCallStack => [a] -> Int -> a
!! BlockHeight -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (r
par.height BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
- BlockHeight
sh)
          Bool -> t m () -> t m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BlockNode
sn.height BlockHeight -> BlockHeight -> Bool
forall a. Eq a => a -> a -> Bool
/= BlockHeight
sh) (t m () -> t m ()) -> t m () -> t m ()
forall a b. (a -> b) -> a -> b
$
            String -> t m ()
forall a. String -> t m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"BUG: Node height not right in skip"
          BlockNode -> t m BlockNode
forall a. a -> t m a
forall (m :: * -> *) a. Monad m => a -> m a
return BlockNode
sn
      where
        sh :: BlockHeight
sh = BlockHeight -> BlockHeight
skipHeight (r
par.height BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
+ BlockHeight
1)
    go :: BlockNode
-> [BlockNode]
-> BlockNode
-> BlockNode
-> [BlockNode]
-> [BlockHeader]
-> ExceptT String m [BlockNode]
go BlockNode
_ [BlockNode]
acc BlockNode
_ BlockNode
_ [BlockNode]
_ [] = [BlockNode] -> ExceptT String m [BlockNode]
forall a. a -> ExceptT String m a
forall (m :: * -> *) a. Monad m => a -> m a
return [BlockNode]
acc
    go BlockNode
lbh [BlockNode]
acc BlockNode
bb BlockNode
par [BlockNode]
pars (BlockHeader
h : [BlockHeader]
hs) = do
      BlockNode
sk <- BlockNode -> [BlockNode] -> BlockNode -> ExceptT String m BlockNode
forall {t :: (* -> *) -> * -> *} {m :: * -> *} {r}.
(MonadTrans t, BlockHeaders m, MonadError String (t m),
 HasField "height" r BlockHeight,
 HasField "header" r BlockHeader) =>
BlockNode -> [BlockNode] -> r -> t m BlockNode
skipit BlockNode
lbh [BlockNode]
acc BlockNode
par
      BlockNode
bn <- m (Either String BlockNode) -> ExceptT String m BlockNode
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either String BlockNode) -> ExceptT String m BlockNode)
-> (Either String BlockNode -> m (Either String BlockNode))
-> Either String BlockNode
-> ExceptT String m BlockNode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either String BlockNode -> m (Either String BlockNode)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String BlockNode -> ExceptT String m BlockNode)
-> Either String BlockNode -> ExceptT String m BlockNode
forall a b. (a -> b) -> a -> b
$ Network
-> BlockHeight
-> BlockNode
-> BlockNode
-> [BlockNode]
-> BlockHeader
-> BlockNode
-> Either String BlockNode
validBlock Network
net BlockHeight
t BlockNode
bb BlockNode
par [BlockNode]
pars BlockHeader
h BlockNode
sk
      BlockNode
-> [BlockNode]
-> BlockNode
-> BlockNode
-> [BlockNode]
-> [BlockHeader]
-> ExceptT String m [BlockNode]
go BlockNode
lbh (BlockNode
bn BlockNode -> [BlockNode] -> [BlockNode]
forall a. a -> [a] -> [a]
: [BlockNode]
acc) (BlockNode -> BlockNode -> BlockNode
chooseBest BlockNode
bn BlockNode
bb) BlockNode
bn (Int -> [BlockNode] -> [BlockNode]
forall a. Int -> [a] -> [a]
take Int
10 ([BlockNode] -> [BlockNode]) -> [BlockNode] -> [BlockNode]
forall a b. (a -> b) -> a -> b
$ BlockNode
par BlockNode -> [BlockNode] -> [BlockNode]
forall a. a -> [a] -> [a]
: [BlockNode]
pars) [BlockHeader]
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 :: forall (m :: * -> *).
BlockHeaders m =>
BlockHeader -> m (Maybe BlockNode)
parentBlock = BlockHash -> m (Maybe BlockNode)
forall (m :: * -> *).
BlockHeaders m =>
BlockHash -> m (Maybe BlockNode)
getBlockHeader (BlockHash -> m (Maybe BlockNode))
-> (BlockHeader -> BlockHash) -> BlockHeader -> m (Maybe BlockNode)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.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 :: forall (m :: * -> *).
BlockHeaders m =>
Network
-> BlockHeight -> BlockHeader -> m (Either String BlockNode)
connectBlock Network
net BlockHeight
t BlockHeader
bh =
  ExceptT String m BlockNode -> m (Either String BlockNode)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT String m BlockNode -> m (Either String BlockNode))
-> ExceptT String m BlockNode -> m (Either String BlockNode)
forall a b. (a -> b) -> a -> b
$ do
    BlockNode
par <-
      String -> MaybeT m BlockNode -> ExceptT String m BlockNode
forall (m :: * -> *) e a.
Functor m =>
e -> MaybeT m a -> ExceptT e m a
maybeToExceptT
        String
"Could not get parent block"
        (m (Maybe BlockNode) -> MaybeT m BlockNode
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (BlockHeader -> m (Maybe BlockNode)
forall (m :: * -> *).
BlockHeaders m =>
BlockHeader -> m (Maybe BlockNode)
parentBlock BlockHeader
bh))
    [BlockNode]
pars <- m [BlockNode] -> ExceptT String m [BlockNode]
forall (m :: * -> *) a. Monad m => m a -> ExceptT String m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [BlockNode] -> ExceptT String m [BlockNode])
-> m [BlockNode] -> ExceptT String m [BlockNode]
forall a b. (a -> b) -> a -> b
$ Int -> BlockNode -> m [BlockNode]
forall (m :: * -> *).
BlockHeaders m =>
Int -> BlockNode -> m [BlockNode]
getParents Int
10 BlockNode
par
    Maybe BlockNode
skM <- m (Maybe BlockNode) -> ExceptT String m (Maybe BlockNode)
forall (m :: * -> *) a. Monad m => m a -> ExceptT String m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Maybe BlockNode) -> ExceptT String m (Maybe BlockNode))
-> m (Maybe BlockNode) -> ExceptT String m (Maybe BlockNode)
forall a b. (a -> b) -> a -> b
$ BlockHeight -> BlockNode -> m (Maybe BlockNode)
forall (m :: * -> *).
BlockHeaders m =>
BlockHeight -> BlockNode -> m (Maybe BlockNode)
getAncestor (BlockHeight -> BlockHeight
skipHeight (BlockNode
par.height BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
+ BlockHeight
1)) BlockNode
par
    BlockNode
sk <-
      case Maybe BlockNode
skM of
        Just BlockNode
sk -> BlockNode -> ExceptT String m BlockNode
forall a. a -> ExceptT String m a
forall (m :: * -> *) a. Monad m => a -> m a
return BlockNode
sk
        Maybe BlockNode
Nothing ->
          String -> ExceptT String m BlockNode
forall a. String -> ExceptT String m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> ExceptT String m BlockNode)
-> String -> ExceptT String m BlockNode
forall a b. (a -> b) -> a -> b
$
            String
"BUG: Could not get skip for block "
              String -> ShowS
forall a. [a] -> [a] -> [a]
++ BlockHash -> String
forall a. Show a => a -> String
show (BlockHeader -> BlockHash
headerHash (BlockHeader -> BlockHash) -> BlockHeader -> BlockHash
forall a b. (a -> b) -> a -> b
$ BlockNode
par.header)
    BlockNode
bb <- m BlockNode -> ExceptT String m BlockNode
forall (m :: * -> *) a. Monad m => m a -> ExceptT String m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m BlockNode
forall (m :: * -> *). BlockHeaders m => m BlockNode
getBestBlockHeader
    BlockNode
bn <- m (Either String BlockNode) -> ExceptT String m BlockNode
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either String BlockNode) -> ExceptT String m BlockNode)
-> (Either String BlockNode -> m (Either String BlockNode))
-> Either String BlockNode
-> ExceptT String m BlockNode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either String BlockNode -> m (Either String BlockNode)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String BlockNode -> ExceptT String m BlockNode)
-> Either String BlockNode -> ExceptT String m BlockNode
forall a b. (a -> b) -> a -> b
$ Network
-> BlockHeight
-> BlockNode
-> BlockNode
-> [BlockNode]
-> BlockHeader
-> BlockNode
-> Either String BlockNode
validBlock Network
net BlockHeight
t BlockNode
bb BlockNode
par [BlockNode]
pars BlockHeader
bh BlockNode
sk
    let bb' :: BlockNode
bb' = BlockNode -> BlockNode -> BlockNode
chooseBest BlockNode
bb BlockNode
bn
    m () -> ExceptT String m ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT String m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ExceptT String m ()) -> m () -> ExceptT String m ()
forall a b. (a -> b) -> a -> b
$ BlockNode -> m ()
forall (m :: * -> *). BlockHeaders m => BlockNode -> m ()
addBlockHeader BlockNode
bn
    Bool -> ExceptT String m () -> ExceptT String m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BlockNode
bb BlockNode -> BlockNode -> Bool
forall a. Eq a => a -> a -> Bool
/= BlockNode
bb') (ExceptT String m () -> ExceptT String m ())
-> (m () -> ExceptT String m ()) -> m () -> ExceptT String m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m () -> ExceptT String m ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT String m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ExceptT String m ()) -> m () -> ExceptT String m ()
forall a b. (a -> b) -> a -> b
$ BlockNode -> m ()
forall (m :: * -> *). BlockHeaders m => BlockNode -> m ()
setBestBlockHeader BlockNode
bb'
    BlockNode -> ExceptT String m BlockNode
forall a. a -> ExceptT String m a
forall (m :: * -> *) a. Monad m => a -> m a
return BlockNode
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 :: Network
-> BlockHeight
-> BlockNode
-> BlockNode
-> [BlockNode]
-> BlockHeader
-> BlockNode
-> Either String BlockNode
validBlock Network
net BlockHeight
t BlockNode
bb BlockNode
par [BlockNode]
pars BlockHeader
bh BlockNode
sk = do
  let mt :: BlockHeight
mt = [BlockHeight] -> BlockHeight
medianTime ([BlockHeight] -> BlockHeight)
-> ([BlockNode] -> [BlockHeight]) -> [BlockNode] -> BlockHeight
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BlockNode -> BlockHeight) -> [BlockNode] -> [BlockHeight]
forall a b. (a -> b) -> [a] -> [b]
map (.header.timestamp) ([BlockNode] -> BlockHeight) -> [BlockNode] -> BlockHeight
forall a b. (a -> b) -> a -> b
$ BlockNode
par BlockNode -> [BlockNode] -> [BlockNode]
forall a. a -> [a] -> [a]
: [BlockNode]
pars
      nt :: BlockHeight
nt = BlockHeader
bh.timestamp
      hh :: BlockHash
hh = BlockHeader -> BlockHash
headerHash BlockHeader
bh
      nv :: BlockHeight
nv = BlockHeader
bh.version
      ng :: BlockHeight
ng = BlockNode
par.height BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
+ BlockHeight
1
      aw :: BlockWork
aw = BlockNode
par.work BlockWork -> BlockWork -> BlockWork
forall a. Num a => a -> a -> a
+ BlockHeader -> BlockWork
headerWork BlockHeader
bh
  Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Network -> BlockHeader -> Bool
isValidPOW Network
net BlockHeader
bh) (Either String () -> Either String ())
-> Either String () -> Either String ()
forall a b. (a -> b) -> a -> b
$
    String -> Either String ()
forall a b. a -> Either a b
Left (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$
      String
"Proof of work failed: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ BlockHash -> String
forall a. Show a => a -> String
show (BlockHeader -> BlockHash
headerHash BlockHeader
bh)
  Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (BlockHeight
nt BlockHeight -> BlockHeight -> Bool
forall a. Ord a => a -> a -> Bool
<= BlockHeight
t BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
+ BlockHeight
2 BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
* BlockHeight
60 BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
* BlockHeight
60) (Either String () -> Either String ())
-> Either String () -> Either String ()
forall a b. (a -> b) -> a -> b
$
    String -> Either String ()
forall a b. a -> Either a b
Left (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$
      String
"Invalid header timestamp: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ BlockHeight -> String
forall a. Show a => a -> String
show BlockHeight
nt
  Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (BlockHeight
nt BlockHeight -> BlockHeight -> Bool
forall a. Ord a => a -> a -> Bool
>= BlockHeight
mt) (Either String () -> Either String ())
-> Either String () -> Either String ()
forall a b. (a -> b) -> a -> b
$
    String -> Either String ()
forall a b. a -> Either a b
Left (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$
      String
"Block timestamp too early: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ BlockHeight -> String
forall a. Show a => a -> String
show BlockHeight
nt
  Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Network -> BlockHeight -> BlockHeight -> Bool
afterLastCP Network
net (BlockNode
bb.height) BlockHeight
ng) (Either String () -> Either String ())
-> Either String () -> Either String ()
forall a b. (a -> b) -> a -> b
$
    String -> Either String ()
forall a b. a -> Either a b
Left (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$
      String
"Rewriting pre-checkpoint chain: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ BlockHeight -> String
forall a. Show a => a -> String
show BlockHeight
ng
  Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Network -> BlockHeight -> BlockHash -> Bool
validCP Network
net BlockHeight
ng BlockHash
hh) (Either String () -> Either String ())
-> Either String () -> Either String ()
forall a b. (a -> b) -> a -> b
$
    String -> Either String ()
forall a b. a -> Either a b
Left (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$
      String
"Rejected checkpoint: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ BlockHeight -> String
forall a. Show a => a -> String
show BlockHeight
ng
  Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Network -> BlockHeight -> BlockHash -> Bool
bip34 Network
net BlockHeight
ng BlockHash
hh) (Either String () -> Either String ())
-> Either String () -> Either String ()
forall a b. (a -> b) -> a -> b
$
    String -> Either String ()
forall a b. a -> Either a b
Left (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$
      String
"Rejected BIP-34 block: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ BlockHash -> String
forall a. Show a => a -> String
show BlockHash
hh
  Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Network -> BlockHeight -> BlockHeight -> Bool
validVersion Network
net BlockHeight
ng BlockHeight
nv) (Either String () -> Either String ())
-> Either String () -> Either String ()
forall a b. (a -> b) -> a -> b
$
    String -> Either String ()
forall a b. a -> Either a b
Left (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$
      String
"Invalid block version: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ BlockHeight -> String
forall a. Show a => a -> String
show BlockHeight
nv
  BlockNode -> Either String BlockNode
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return
    BlockNode
      { $sel:header:BlockNode :: BlockHeader
header = BlockHeader
bh,
        $sel:height:BlockNode :: BlockHeight
height = BlockHeight
ng,
        $sel:work:BlockNode :: BlockWork
work = BlockWork
aw,
        $sel:skip:BlockNode :: BlockHash
skip = BlockHeader -> BlockHash
headerHash BlockNode
sk.header
      }

-- | Return the median of all provided timestamps. Can be unsorted. Error on
-- empty list.
medianTime :: [Timestamp] -> Timestamp
medianTime :: [BlockHeight] -> BlockHeight
medianTime [BlockHeight]
ts
  | [BlockHeight] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [BlockHeight]
ts = String -> BlockHeight
forall a. HasCallStack => String -> a
error String
"Cannot compute median time of empty header list"
  | Bool
otherwise = [BlockHeight] -> [BlockHeight]
forall a. Ord a => [a] -> [a]
sort [BlockHeight]
ts [BlockHeight] -> Int -> BlockHeight
forall a. HasCallStack => [a] -> Int -> a
!! ([BlockHeight] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BlockHeight]
ts Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
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 :: BlockHeight -> BlockHeight
skipHeight BlockHeight
height
  | BlockHeight
height BlockHeight -> BlockHeight -> Bool
forall a. Ord a => a -> a -> Bool
< BlockHeight
2 = BlockHeight
0
  | BlockHeight
height BlockHeight -> BlockHeight -> BlockHeight
forall a. Bits a => a -> a -> a
.&. BlockHeight
1 BlockHeight -> BlockHeight -> Bool
forall a. Eq a => a -> a -> Bool
/= BlockHeight
0 = BlockHeight -> BlockHeight
invertLowestOne (BlockHeight -> BlockHeight
invertLowestOne (BlockHeight -> BlockHeight) -> BlockHeight -> BlockHeight
forall a b. (a -> b) -> a -> b
$ BlockHeight
height BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
- BlockHeight
1) BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
+ BlockHeight
1
  | Bool
otherwise = BlockHeight -> BlockHeight
invertLowestOne BlockHeight
height

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

-- | Get a number of parents for the provided block.
getParents ::
  (BlockHeaders m) =>
  Int ->
  BlockNode ->
  -- | starts from immediate parent
  m [BlockNode]
getParents :: forall (m :: * -> *).
BlockHeaders m =>
Int -> BlockNode -> m [BlockNode]
getParents = [BlockNode] -> Int -> BlockNode -> m [BlockNode]
forall {t} {m :: * -> *}.
(Eq t, Num t, BlockHeaders m) =>
[BlockNode] -> t -> BlockNode -> m [BlockNode]
getpars []
  where
    getpars :: [BlockNode] -> t -> BlockNode -> m [BlockNode]
getpars [BlockNode]
acc t
0 BlockNode
_ = [BlockNode] -> m [BlockNode]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([BlockNode] -> m [BlockNode]) -> [BlockNode] -> m [BlockNode]
forall a b. (a -> b) -> a -> b
$ [BlockNode] -> [BlockNode]
forall a. [a] -> [a]
reverse [BlockNode]
acc
    getpars [BlockNode]
acc t
n BlockNode {BlockWork
BlockHeight
BlockHeader
BlockHash
$sel:header:BlockNode :: BlockNode -> BlockHeader
$sel:height:BlockNode :: BlockNode -> BlockHeight
$sel:work:BlockNode :: BlockNode -> BlockWork
$sel:skip:BlockNode :: BlockNode -> BlockHash
header :: BlockHeader
height :: BlockHeight
work :: BlockWork
skip :: BlockHash
..}
      | BlockHeight
height BlockHeight -> BlockHeight -> Bool
forall a. Eq a => a -> a -> Bool
== BlockHeight
0 = [BlockNode] -> m [BlockNode]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([BlockNode] -> m [BlockNode]) -> [BlockNode] -> m [BlockNode]
forall a b. (a -> b) -> a -> b
$ [BlockNode] -> [BlockNode]
forall a. [a] -> [a]
reverse [BlockNode]
acc
      | Bool
otherwise = do
          Maybe BlockNode
parM <- BlockHash -> m (Maybe BlockNode)
forall (m :: * -> *).
BlockHeaders m =>
BlockHash -> m (Maybe BlockNode)
getBlockHeader BlockHeader
header.prev
          case Maybe BlockNode
parM of
            Just BlockNode
bn -> [BlockNode] -> t -> BlockNode -> m [BlockNode]
getpars (BlockNode
bn BlockNode -> [BlockNode] -> [BlockNode]
forall a. a -> [a] -> [a]
: [BlockNode]
acc) (t
n t -> t -> t
forall a. Num a => a -> a -> a
- t
1) BlockNode
bn
            Maybe BlockNode
Nothing -> String -> m [BlockNode]
forall a. HasCallStack => String -> a
error String
"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 :: Network -> BlockHeight -> BlockHash -> Bool
validCP Network
net BlockHeight
height BlockHash
newChildHash =
  case BlockHeight -> [(BlockHeight, BlockHash)] -> Maybe BlockHash
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup BlockHeight
height Network
net.checkpoints of
    Just BlockHash
cpHash -> BlockHash
cpHash BlockHash -> BlockHash -> Bool
forall a. Eq a => a -> a -> Bool
== BlockHash
newChildHash
    Maybe BlockHash
Nothing -> Bool
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 :: Network -> BlockHeight -> BlockHeight -> Bool
afterLastCP Network
net BlockHeight
bestHeight BlockHeight
newChildHeight =
  case Maybe BlockHeight
lM of
    Just BlockHeight
l -> BlockHeight
l BlockHeight -> BlockHeight -> Bool
forall a. Ord a => a -> a -> Bool
< BlockHeight
newChildHeight
    Maybe BlockHeight
Nothing -> Bool
True
  where
    lM :: Maybe BlockHeight
lM =
      [BlockHeight] -> Maybe BlockHeight
forall a. [a] -> Maybe a
listToMaybe ([BlockHeight] -> Maybe BlockHeight)
-> ([BlockHeight] -> [BlockHeight])
-> [BlockHeight]
-> Maybe BlockHeight
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [BlockHeight] -> [BlockHeight]
forall a. [a] -> [a]
reverse ([BlockHeight] -> Maybe BlockHeight)
-> [BlockHeight] -> Maybe BlockHeight
forall a b. (a -> b) -> a -> b
$
        [BlockHeight
c | (BlockHeight
c, BlockHash
_) <- Network
net.checkpoints, BlockHeight
c BlockHeight -> BlockHeight -> Bool
forall a. Ord a => a -> a -> Bool
<= BlockHeight
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 :: Network -> BlockHeight -> BlockHash -> Bool
bip34 Network
net BlockHeight
height BlockHash
hsh
  | (BlockHeight, BlockHash) -> BlockHeight
forall a b. (a, b) -> a
fst Network
net.bip34Block BlockHeight -> BlockHeight -> Bool
forall a. Eq a => a -> a -> Bool
== BlockHeight
0 = Bool
True
  | (BlockHeight, BlockHash) -> BlockHeight
forall a b. (a, b) -> a
fst Network
net.bip34Block BlockHeight -> BlockHeight -> Bool
forall a. Eq a => a -> a -> Bool
== BlockHeight
height = (BlockHeight, BlockHash) -> BlockHash
forall a b. (a, b) -> b
snd Network
net.bip34Block BlockHash -> BlockHash -> Bool
forall a. Eq a => a -> a -> Bool
== BlockHash
hsh
  | Bool
otherwise = Bool
True

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

-- | Find last block with normal, as opposed to minimum difficulty (for test
-- networks).
lastNoMinDiff :: (BlockHeaders m) => Network -> BlockNode -> m BlockNode
lastNoMinDiff :: forall (m :: * -> *).
BlockHeaders m =>
Network -> BlockNode -> m BlockNode
lastNoMinDiff Network
_ bn :: BlockNode
bn@BlockNode {$sel:height:BlockNode :: BlockNode -> BlockHeight
height = BlockHeight
0} = BlockNode -> m BlockNode
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return BlockNode
bn
lastNoMinDiff Network
net BlockNode
bn = do
  let i :: Bool
i = BlockNode
bn.height BlockHeight -> BlockHeight -> BlockHeight
forall a. Integral a => a -> a -> a
`mod` Network -> BlockHeight
diffInterval Network
net BlockHeight -> BlockHeight -> Bool
forall a. Eq a => a -> a -> Bool
/= BlockHeight
0
      c :: BlockHeight
c = BlockWork -> BlockHeight
encodeCompact Network
net.powLimit
      l :: Bool
l = BlockNode
bn.header.bits BlockHeight -> BlockHeight -> Bool
forall a. Eq a => a -> a -> Bool
== BlockHeight
c
      e1 :: a
e1 =
        String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$
          String
"Could not get block header for parent of "
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ BlockHash -> String
forall a. Show a => a -> String
show (BlockHeader -> BlockHash
headerHash BlockNode
bn.header)
  if Bool
i Bool -> Bool -> Bool
&& Bool
l
    then do
      BlockNode
bn' <- BlockNode -> Maybe BlockNode -> BlockNode
forall a. a -> Maybe a -> a
fromMaybe BlockNode
forall {a}. a
e1 (Maybe BlockNode -> BlockNode)
-> m (Maybe BlockNode) -> m BlockNode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockHash -> m (Maybe BlockNode)
forall (m :: * -> *).
BlockHeaders m =>
BlockHash -> m (Maybe BlockNode)
getBlockHeader (BlockNode
bn.header.prev)
      Network -> BlockNode -> m BlockNode
forall (m :: * -> *).
BlockHeaders m =>
Network -> BlockNode -> m BlockNode
lastNoMinDiff Network
net BlockNode
bn'
    else BlockNode -> m BlockNode
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return BlockNode
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 :: forall (m :: * -> *).
BlockHeaders m =>
Network -> BlockNode -> BlockHeader -> m BlockHeight
nextWorkRequired Network
net BlockNode
par BlockHeader
bh = do
  Maybe BlockNode
ma <- Network -> m (Maybe BlockNode)
forall (m :: * -> *).
BlockHeaders m =>
Network -> m (Maybe BlockNode)
getAsertAnchor Network
net
  case Maybe BlockNode
-> Maybe (BlockNode -> BlockHeader -> m BlockHeight)
forall {m :: * -> *} {m :: * -> *}.
(Alternative m, BlockHeaders m, Monad m) =>
m BlockNode -> m (BlockNode -> BlockHeader -> m BlockHeight)
asert Maybe BlockNode
ma Maybe (BlockNode -> BlockHeader -> m BlockHeight)
-> Maybe (BlockNode -> BlockHeader -> m BlockHeight)
-> Maybe (BlockNode -> BlockHeader -> m BlockHeight)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe (BlockNode -> BlockHeader -> m BlockHeight)
daa Maybe (BlockNode -> BlockHeader -> m BlockHeight)
-> Maybe (BlockNode -> BlockHeader -> m BlockHeight)
-> Maybe (BlockNode -> BlockHeader -> m BlockHeight)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe (BlockNode -> BlockHeader -> m BlockHeight)
eda Maybe (BlockNode -> BlockHeader -> m BlockHeight)
-> Maybe (BlockNode -> BlockHeader -> m BlockHeight)
-> Maybe (BlockNode -> BlockHeader -> m BlockHeight)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe (BlockNode -> BlockHeader -> m BlockHeight)
pow of
    Just BlockNode -> BlockHeader -> m BlockHeight
f -> BlockNode -> BlockHeader -> m BlockHeight
f BlockNode
par BlockHeader
bh
    Maybe (BlockNode -> BlockHeader -> m BlockHeight)
Nothing -> String -> m BlockHeight
forall a. HasCallStack => String -> a
error String
"Could not determine difficulty algorithm"
  where
    asert :: m BlockNode -> m (BlockNode -> BlockHeader -> m BlockHeight)
asert m BlockNode
ma = do
      BlockNode
anchor <- m BlockNode
ma
      Bool -> m ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (BlockNode
par.height BlockHeight -> BlockHeight -> Bool
forall a. Ord a => a -> a -> Bool
> BlockNode
anchor.height)
      (BlockNode -> BlockHeader -> m BlockHeight)
-> m (BlockNode -> BlockHeader -> m BlockHeight)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((BlockNode -> BlockHeader -> m BlockHeight)
 -> m (BlockNode -> BlockHeader -> m BlockHeight))
-> (BlockNode -> BlockHeader -> m BlockHeight)
-> m (BlockNode -> BlockHeader -> m BlockHeight)
forall a b. (a -> b) -> a -> b
$ Network -> BlockNode -> BlockNode -> BlockHeader -> m BlockHeight
forall (m :: * -> *).
BlockHeaders m =>
Network -> BlockNode -> BlockNode -> BlockHeader -> m BlockHeight
nextAsertWorkRequired Network
net BlockNode
anchor
    daa :: Maybe (BlockNode -> BlockHeader -> m BlockHeight)
daa = do
      BlockHeight
daa_height <- Network
net.daaHeight
      Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (BlockNode
par.height BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
+ BlockHeight
1 BlockHeight -> BlockHeight -> Bool
forall a. Ord a => a -> a -> Bool
>= BlockHeight
daa_height)
      (BlockNode -> BlockHeader -> m BlockHeight)
-> Maybe (BlockNode -> BlockHeader -> m BlockHeight)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return ((BlockNode -> BlockHeader -> m BlockHeight)
 -> Maybe (BlockNode -> BlockHeader -> m BlockHeight))
-> (BlockNode -> BlockHeader -> m BlockHeight)
-> Maybe (BlockNode -> BlockHeader -> m BlockHeight)
forall a b. (a -> b) -> a -> b
$ Network -> BlockNode -> BlockHeader -> m BlockHeight
forall (m :: * -> *).
BlockHeaders m =>
Network -> BlockNode -> BlockHeader -> m BlockHeight
nextDaaWorkRequired Network
net
    eda :: Maybe (BlockNode -> BlockHeader -> m BlockHeight)
eda = do
      BlockHeight
eda_height <- Network
net.edaHeight
      Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (BlockNode
par.height BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
+ BlockHeight
1 BlockHeight -> BlockHeight -> Bool
forall a. Ord a => a -> a -> Bool
>= BlockHeight
eda_height)
      (BlockNode -> BlockHeader -> m BlockHeight)
-> Maybe (BlockNode -> BlockHeader -> m BlockHeight)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return ((BlockNode -> BlockHeader -> m BlockHeight)
 -> Maybe (BlockNode -> BlockHeader -> m BlockHeight))
-> (BlockNode -> BlockHeader -> m BlockHeight)
-> Maybe (BlockNode -> BlockHeader -> m BlockHeight)
forall a b. (a -> b) -> a -> b
$ Network -> BlockNode -> BlockHeader -> m BlockHeight
forall (m :: * -> *).
BlockHeaders m =>
Network -> BlockNode -> BlockHeader -> m BlockHeight
nextEdaWorkRequired Network
net
    pow :: Maybe (BlockNode -> BlockHeader -> m BlockHeight)
pow = (BlockNode -> BlockHeader -> m BlockHeight)
-> Maybe (BlockNode -> BlockHeader -> m BlockHeight)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return ((BlockNode -> BlockHeader -> m BlockHeight)
 -> Maybe (BlockNode -> BlockHeader -> m BlockHeight))
-> (BlockNode -> BlockHeader -> m BlockHeight)
-> Maybe (BlockNode -> BlockHeader -> m BlockHeight)
forall a b. (a -> b) -> a -> b
$ Network -> BlockNode -> BlockHeader -> m BlockHeight
forall (m :: * -> *).
BlockHeaders m =>
Network -> BlockNode -> BlockHeader -> m BlockHeight
nextPowWorkRequired Network
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 :: forall (m :: * -> *).
BlockHeaders m =>
Network -> BlockNode -> BlockHeader -> m BlockHeight
nextEdaWorkRequired Network
net BlockNode
par BlockHeader
bh
  | BlockNode
par.height BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
+ BlockHeight
1 BlockHeight -> BlockHeight -> BlockHeight
forall a. Integral a => a -> a -> a
`mod` Network -> BlockHeight
diffInterval Network
net BlockHeight -> BlockHeight -> Bool
forall a. Eq a => a -> a -> Bool
== BlockHeight
0 =
      Network -> BlockNode -> BlockHeader -> m BlockHeight
forall (m :: * -> *).
BlockHeaders m =>
Network -> BlockNode -> BlockHeader -> m BlockHeight
nextWorkRequired Network
net BlockNode
par BlockHeader
bh
  | Bool
mindiff = BlockHeight -> m BlockHeight
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockWork -> BlockHeight
encodeCompact Network
net.powLimit)
  | BlockNode
par.header.bits BlockHeight -> BlockHeight -> Bool
forall a. Eq a => a -> a -> Bool
== BlockWork -> BlockHeight
encodeCompact Network
net.powLimit =
      BlockHeight -> m BlockHeight
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockWork -> BlockHeight
encodeCompact Network
net.powLimit)
  | Bool
otherwise = do
      BlockNode
par6 <- BlockNode -> Maybe BlockNode -> BlockNode
forall a. a -> Maybe a -> a
fromMaybe BlockNode
forall {a}. a
e1 (Maybe BlockNode -> BlockNode)
-> m (Maybe BlockNode) -> m BlockNode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockHeight -> BlockNode -> m (Maybe BlockNode)
forall (m :: * -> *).
BlockHeaders m =>
BlockHeight -> BlockNode -> m (Maybe BlockNode)
getAncestor (BlockNode
par.height BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
- BlockHeight
6) BlockNode
par
      [BlockNode]
pars <- Int -> BlockNode -> m [BlockNode]
forall (m :: * -> *).
BlockHeaders m =>
Int -> BlockNode -> m [BlockNode]
getParents Int
10 BlockNode
par
      [BlockNode]
pars6 <- Int -> BlockNode -> m [BlockNode]
forall (m :: * -> *).
BlockHeaders m =>
Int -> BlockNode -> m [BlockNode]
getParents Int
10 BlockNode
par6
      let par6med :: BlockHeight
par6med =
            [BlockHeight] -> BlockHeight
medianTime ([BlockHeight] -> BlockHeight) -> [BlockHeight] -> BlockHeight
forall a b. (a -> b) -> a -> b
$ (BlockNode -> BlockHeight) -> [BlockNode] -> [BlockHeight]
forall a b. (a -> b) -> [a] -> [b]
map (.header.timestamp) (BlockNode
par6 BlockNode -> [BlockNode] -> [BlockNode]
forall a. a -> [a] -> [a]
: [BlockNode]
pars6)
          parmed :: BlockHeight
parmed = [BlockHeight] -> BlockHeight
medianTime ([BlockHeight] -> BlockHeight) -> [BlockHeight] -> BlockHeight
forall a b. (a -> b) -> a -> b
$ (BlockNode -> BlockHeight) -> [BlockNode] -> [BlockHeight]
forall a b. (a -> b) -> [a] -> [b]
map (.header.timestamp) (BlockNode
par BlockNode -> [BlockNode] -> [BlockNode]
forall a. a -> [a] -> [a]
: [BlockNode]
pars)
          mtp6 :: BlockHeight
mtp6 = BlockHeight
parmed BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
- BlockHeight
par6med
      if BlockHeight
mtp6 BlockHeight -> BlockHeight -> Bool
forall a. Ord a => a -> a -> Bool
< BlockHeight
12 BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
* BlockHeight
3600
        then BlockHeight -> m BlockHeight
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockHeight -> m BlockHeight) -> BlockHeight -> m BlockHeight
forall a b. (a -> b) -> a -> b
$ BlockNode
par.header.bits
        else
          BlockHeight -> m BlockHeight
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockHeight -> m BlockHeight) -> BlockHeight -> m BlockHeight
forall a b. (a -> b) -> a -> b
$
            let (BlockWork
diff, Bool
_) = BlockHeight -> (BlockWork, Bool)
decodeCompact BlockNode
par.header.bits
                ndiff :: BlockWork
ndiff = BlockWork
diff BlockWork -> BlockWork -> BlockWork
forall a. Num a => a -> a -> a
+ (BlockWork
diff BlockWork -> Int -> BlockWork
forall a. Bits a => a -> Int -> a
`shiftR` Int
2)
             in if Network
net.powLimit BlockWork -> BlockWork -> Bool
forall a. Ord a => a -> a -> Bool
> BlockWork
ndiff
                  then BlockWork -> BlockHeight
encodeCompact Network
net.powLimit
                  else BlockWork -> BlockHeight
encodeCompact BlockWork
ndiff
  where
    mindiff :: Bool
mindiff = BlockHeader
bh.timestamp BlockHeight -> BlockHeight -> Bool
forall a. Ord a => a -> a -> Bool
> BlockNode
par.header.timestamp BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
+ Network
net.targetSpacing BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
* BlockHeight
2
    e1 :: a
e1 = String -> a
forall a. HasCallStack => String -> a
error String
"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 :: forall (m :: * -> *).
BlockHeaders m =>
Network -> BlockNode -> BlockHeader -> m BlockHeight
nextDaaWorkRequired Network
net BlockNode
par BlockHeader
bh
  | Bool
mindiff = BlockHeight -> m BlockHeight
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockWork -> BlockHeight
encodeCompact Network
net.powLimit)
  | Bool
otherwise = do
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (BlockNode
par.height BlockHeight -> BlockHeight -> Bool
forall a. Ord a => a -> a -> Bool
>= Network -> BlockHeight
diffInterval Network
net) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
        String -> m ()
forall a. HasCallStack => String -> a
error String
"Block height below difficulty interval"
      BlockNode
l <- BlockNode -> m BlockNode
forall (m :: * -> *). BlockHeaders m => BlockNode -> m BlockNode
getSuitableBlock BlockNode
par
      BlockNode
par144 <- BlockNode -> Maybe BlockNode -> BlockNode
forall a. a -> Maybe a -> a
fromMaybe BlockNode
forall {a}. a
e1 (Maybe BlockNode -> BlockNode)
-> m (Maybe BlockNode) -> m BlockNode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockHeight -> BlockNode -> m (Maybe BlockNode)
forall (m :: * -> *).
BlockHeaders m =>
BlockHeight -> BlockNode -> m (Maybe BlockNode)
getAncestor (BlockNode
par.height BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
- BlockHeight
144) BlockNode
par
      BlockNode
f <- BlockNode -> m BlockNode
forall (m :: * -> *). BlockHeaders m => BlockNode -> m BlockNode
getSuitableBlock BlockNode
par144
      let nextTarget :: BlockWork
nextTarget = Network -> BlockNode -> BlockNode -> BlockWork
computeTarget Network
net BlockNode
f BlockNode
l
      if BlockWork
nextTarget BlockWork -> BlockWork -> Bool
forall a. Ord a => a -> a -> Bool
> Network
net.powLimit
        then BlockHeight -> m BlockHeight
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockHeight -> m BlockHeight) -> BlockHeight -> m BlockHeight
forall a b. (a -> b) -> a -> b
$ BlockWork -> BlockHeight
encodeCompact Network
net.powLimit
        else BlockHeight -> m BlockHeight
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockHeight -> m BlockHeight) -> BlockHeight -> m BlockHeight
forall a b. (a -> b) -> a -> b
$ BlockWork -> BlockHeight
encodeCompact BlockWork
nextTarget
  where
    e1 :: a
e1 = String -> a
forall a. HasCallStack => String -> a
error String
"Cannot get ancestor at parent - 144 height"
    mindiff :: Bool
mindiff = BlockHeader
bh.timestamp BlockHeight -> BlockHeight -> Bool
forall a. Ord a => a -> a -> Bool
> BlockNode
par.header.timestamp BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
+ Network
net.targetSpacing BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
* BlockHeight
2

mtp :: (BlockHeaders m) => BlockNode -> m Timestamp
mtp :: forall (m :: * -> *). BlockHeaders m => BlockNode -> m BlockHeight
mtp BlockNode
bn
  | BlockNode
bn.height BlockHeight -> BlockHeight -> Bool
forall a. Eq a => a -> a -> Bool
== BlockHeight
0 = BlockHeight -> m BlockHeight
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return BlockHeight
0
  | Bool
otherwise = do
      [BlockNode]
pars <- Int -> BlockNode -> m [BlockNode]
forall (m :: * -> *).
BlockHeaders m =>
Int -> BlockNode -> m [BlockNode]
getParents Int
11 BlockNode
bn
      BlockHeight -> m BlockHeight
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockHeight -> m BlockHeight) -> BlockHeight -> m BlockHeight
forall a b. (a -> b) -> a -> b
$ [BlockHeight] -> BlockHeight
medianTime ((BlockNode -> BlockHeight) -> [BlockNode] -> [BlockHeight]
forall a b. (a -> b) -> [a] -> [b]
map (.header.timestamp) [BlockNode]
pars)

firstGreaterOrEqual ::
  (BlockHeaders m) =>
  Network ->
  (BlockNode -> m Ordering) ->
  m (Maybe BlockNode)
firstGreaterOrEqual :: forall (m :: * -> *).
BlockHeaders m =>
Network -> (BlockNode -> m Ordering) -> m (Maybe BlockNode)
firstGreaterOrEqual = Bool -> Network -> (BlockNode -> m Ordering) -> m (Maybe BlockNode)
forall (m :: * -> *).
BlockHeaders m =>
Bool -> Network -> (BlockNode -> m Ordering) -> m (Maybe BlockNode)
binSearch Bool
False

lastSmallerOrEqual ::
  (BlockHeaders m) =>
  Network ->
  (BlockNode -> m Ordering) ->
  m (Maybe BlockNode)
lastSmallerOrEqual :: forall (m :: * -> *).
BlockHeaders m =>
Network -> (BlockNode -> m Ordering) -> m (Maybe BlockNode)
lastSmallerOrEqual = Bool -> Network -> (BlockNode -> m Ordering) -> m (Maybe BlockNode)
forall (m :: * -> *).
BlockHeaders m =>
Bool -> Network -> (BlockNode -> m Ordering) -> m (Maybe BlockNode)
binSearch Bool
True

binSearch ::
  (BlockHeaders m) =>
  Bool ->
  Network ->
  (BlockNode -> m Ordering) ->
  m (Maybe BlockNode)
binSearch :: forall (m :: * -> *).
BlockHeaders m =>
Bool -> Network -> (BlockNode -> m Ordering) -> m (Maybe BlockNode)
binSearch Bool
top Network
net BlockNode -> m Ordering
f = MaybeT m BlockNode -> m (Maybe BlockNode)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT m BlockNode -> m (Maybe BlockNode))
-> MaybeT m BlockNode -> m (Maybe BlockNode)
forall a b. (a -> b) -> a -> b
$ do
  (BlockNode
a, BlockNode
b) <- m (BlockNode, BlockNode) -> MaybeT m (BlockNode, BlockNode)
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (BlockNode, BlockNode) -> MaybeT m (BlockNode, BlockNode))
-> m (BlockNode, BlockNode) -> MaybeT m (BlockNode, BlockNode)
forall a b. (a -> b) -> a -> b
$ Network -> m (BlockNode, BlockNode)
forall (m :: * -> *).
BlockHeaders m =>
Network -> m (BlockNode, BlockNode)
extremes Network
net
  BlockNode -> BlockNode -> MaybeT m BlockNode
forall {t :: (* -> *) -> * -> *}.
(MonadPlus (t m), MonadTrans t) =>
BlockNode -> BlockNode -> t m BlockNode
go BlockNode
a BlockNode
b
  where
    go :: BlockNode -> BlockNode -> t m BlockNode
go BlockNode
a BlockNode
b = do
      BlockNode
m <- m BlockNode -> t m BlockNode
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m BlockNode -> t m BlockNode) -> m BlockNode -> t m BlockNode
forall a b. (a -> b) -> a -> b
$ BlockNode -> BlockNode -> m BlockNode
forall (m :: * -> *).
BlockHeaders m =>
BlockNode -> BlockNode -> m BlockNode
middleBlock BlockNode
a BlockNode
b
      Ordering
a' <- m Ordering -> t m Ordering
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Ordering -> t m Ordering) -> m Ordering -> t m Ordering
forall a b. (a -> b) -> a -> b
$ BlockNode -> m Ordering
f BlockNode
a
      Ordering
b' <- m Ordering -> t m Ordering
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Ordering -> t m Ordering) -> m Ordering -> t m Ordering
forall a b. (a -> b) -> a -> b
$ BlockNode -> m Ordering
f BlockNode
b
      Ordering
m' <- m Ordering -> t m Ordering
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Ordering -> t m Ordering) -> m Ordering -> t m Ordering
forall a b. (a -> b) -> a -> b
$ BlockNode -> m Ordering
f BlockNode
m
      (BlockNode, Ordering)
-> (BlockNode, Ordering) -> (BlockNode, Ordering) -> t m BlockNode
r (BlockNode
a, Ordering
a') (BlockNode
b, Ordering
b') (BlockNode
m, Ordering
m')
    r :: (BlockNode, Ordering)
-> (BlockNode, Ordering) -> (BlockNode, Ordering) -> t m BlockNode
r (BlockNode
a, Ordering
a') (BlockNode
b, Ordering
b') (BlockNode
m, Ordering
m')
      | Ordering -> Ordering -> Bool
out_of_bounds Ordering
a' Ordering
b' = t m BlockNode
forall a. t m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
      | Ordering -> Bool
select_first Ordering
a' = BlockNode -> t m BlockNode
forall a. a -> t m a
forall (m :: * -> *) a. Monad m => a -> m a
return BlockNode
a
      | Ordering -> Bool
select_last Ordering
b' = BlockNode -> t m BlockNode
forall a. a -> t m a
forall (m :: * -> *) a. Monad m => a -> m a
return BlockNode
b
      | BlockNode -> BlockNode -> Bool
forall {a} {r} {r}.
(Ord a, Num a, HasField "height" r a, HasField "height" r a) =>
r -> r -> Bool
no_middle BlockNode
a BlockNode
b = BlockNode -> BlockNode -> t m BlockNode
forall {m :: * -> *} {a}. Monad m => a -> a -> m a
choose_one BlockNode
a BlockNode
b
      | Ordering -> Ordering -> Bool
is_between Ordering
a' Ordering
m' = BlockNode -> BlockNode -> t m BlockNode
go BlockNode
a BlockNode
m
      | Ordering -> Ordering -> Bool
is_between Ordering
m' Ordering
b' = BlockNode -> BlockNode -> t m BlockNode
go BlockNode
m BlockNode
b
      | Bool
otherwise = t m BlockNode
forall a. t m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
    select_first :: Ordering -> Bool
select_first Ordering
a'
      | Bool -> Bool
not Bool
top = Ordering
a' Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
/= Ordering
LT
      | Bool
otherwise = Bool
False
    select_last :: Ordering -> Bool
select_last Ordering
b'
      | Bool
top = Ordering
b' Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
/= Ordering
GT
      | Bool
otherwise = Bool
False
    out_of_bounds :: Ordering -> Ordering -> Bool
out_of_bounds Ordering
a' Ordering
b'
      | Bool
top = Ordering
a' Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
GT
      | Bool
otherwise = Ordering
b' Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
LT
    no_middle :: r -> r -> Bool
no_middle r
a r
b = r
b.height a -> a -> a
forall a. Num a => a -> a -> a
- r
a.height a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
1
    is_between :: Ordering -> Ordering -> Bool
is_between Ordering
a' Ordering
b' = Ordering
a' Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
/= Ordering
GT Bool -> Bool -> Bool
&& Ordering
b' Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
/= Ordering
LT
    choose_one :: a -> a -> m a
choose_one a
a a
b
      | Bool
top = a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
      | Bool
otherwise = a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
b

extremes :: (BlockHeaders m) => Network -> m (BlockNode, BlockNode)
extremes :: forall (m :: * -> *).
BlockHeaders m =>
Network -> m (BlockNode, BlockNode)
extremes Network
net = do
  BlockNode
b <- m BlockNode
forall (m :: * -> *). BlockHeaders m => m BlockNode
getBestBlockHeader
  (BlockNode, BlockNode) -> m (BlockNode, BlockNode)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Network -> BlockNode
genesisNode Network
net, BlockNode
b)

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

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

-- TODO: Use known anchor after fork
getAsertAnchor :: (BlockHeaders m) => Network -> m (Maybe BlockNode)
getAsertAnchor :: forall (m :: * -> *).
BlockHeaders m =>
Network -> m (Maybe BlockNode)
getAsertAnchor Network
net =
  case Network
net.asertActivationTime of
    Maybe BlockHeight
Nothing -> Maybe BlockNode -> m (Maybe BlockNode)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe BlockNode
forall a. Maybe a
Nothing
    Just BlockHeight
act -> Network -> (BlockNode -> m Ordering) -> m (Maybe BlockNode)
forall (m :: * -> *).
BlockHeaders m =>
Network -> (BlockNode -> m Ordering) -> m (Maybe BlockNode)
firstGreaterOrEqual Network
net (BlockHeight -> BlockNode -> m Ordering
forall {m :: * -> *}.
BlockHeaders m =>
BlockHeight -> BlockNode -> m Ordering
f BlockHeight
act)
  where
    f :: BlockHeight -> BlockNode -> m Ordering
f BlockHeight
act BlockNode
bn = do
      BlockHeight
m <- BlockNode -> m BlockHeight
forall (m :: * -> *). BlockHeaders m => BlockNode -> m BlockHeight
mtp BlockNode
bn
      Ordering -> m Ordering
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Ordering -> m Ordering) -> Ordering -> m Ordering
forall a b. (a -> b) -> a -> b
$ BlockHeight -> BlockHeight -> Ordering
forall a. Ord a => a -> a -> Ordering
compare BlockHeight
m BlockHeight
act

-- | Find the next amount of work required according to the aserti3-2d algorithm.
nextAsertWorkRequired ::
  (BlockHeaders m) =>
  Network ->
  BlockNode ->
  BlockNode ->
  BlockHeader ->
  m Word32
nextAsertWorkRequired :: forall (m :: * -> *).
BlockHeaders m =>
Network -> BlockNode -> BlockNode -> BlockHeader -> m BlockHeight
nextAsertWorkRequired Network
net BlockNode
anchor BlockNode
par BlockHeader
bh = do
  BlockNode
anchor_parent <-
    BlockNode -> Maybe BlockNode -> BlockNode
forall a. a -> Maybe a -> a
fromMaybe BlockNode
forall {a}. a
e_fork (Maybe BlockNode -> BlockNode)
-> m (Maybe BlockNode) -> m BlockNode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockHash -> m (Maybe BlockNode)
forall (m :: * -> *).
BlockHeaders m =>
BlockHash -> m (Maybe BlockNode)
getBlockHeader BlockNode
anchor.header.prev
  let anchor_parent_time :: BlockWork
anchor_parent_time = BlockHeight -> BlockWork
forall a. Integral a => a -> BlockWork
toInteger BlockNode
anchor_parent.header.timestamp
      time_diff :: BlockWork
time_diff = BlockWork
current_time BlockWork -> BlockWork -> BlockWork
forall a. Num a => a -> a -> a
- BlockWork
anchor_parent_time
  BlockHeight -> m BlockHeight
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockHeight -> m BlockHeight) -> BlockHeight -> m BlockHeight
forall a b. (a -> b) -> a -> b
$ BlockWork -> BlockHeight -> BlockWork -> BlockWork -> BlockHeight
computeAsertBits BlockWork
halflife BlockHeight
anchor_bits BlockWork
time_diff BlockWork
height_diff
  where
    halflife :: BlockWork
halflife = Network
net.asertHalfLife
    anchor_height :: BlockWork
anchor_height = BlockHeight -> BlockWork
forall a. Integral a => a -> BlockWork
toInteger BlockNode
anchor.height
    anchor_bits :: BlockHeight
anchor_bits = BlockNode
anchor.header.bits
    current_height :: BlockWork
current_height = BlockHeight -> BlockWork
forall a. Integral a => a -> BlockWork
toInteger BlockNode
par.height BlockWork -> BlockWork -> BlockWork
forall a. Num a => a -> a -> a
+ BlockWork
1
    height_diff :: BlockWork
height_diff = BlockWork
current_height BlockWork -> BlockWork -> BlockWork
forall a. Num a => a -> a -> a
- BlockWork
anchor_height
    current_time :: BlockWork
current_time = BlockHeight -> BlockWork
forall a. Integral a => a -> BlockWork
toInteger BlockHeader
bh.timestamp
    e_fork :: a
e_fork = String -> a
forall a. HasCallStack => String -> a
error String
"Could not get fork block header"

idealBlockTime :: Integer
idealBlockTime :: BlockWork
idealBlockTime = BlockWork
10 BlockWork -> BlockWork -> BlockWork
forall a. Num a => a -> a -> a
* BlockWork
60

rBits :: Int
rBits :: Int
rBits = Int
16

radix :: Integer
radix :: BlockWork
radix = BlockWork
1 BlockWork -> Int -> BlockWork
forall a. Bits a => a -> Int -> a
`shiftL` Int
rBits

maxBits :: Word32
maxBits :: BlockHeight
maxBits = BlockHeight
0x1d00ffff

maxTarget :: Integer
maxTarget :: BlockWork
maxTarget = (BlockWork, Bool) -> BlockWork
forall a b. (a, b) -> a
fst ((BlockWork, Bool) -> BlockWork) -> (BlockWork, Bool) -> BlockWork
forall a b. (a -> b) -> a -> b
$ BlockHeight -> (BlockWork, Bool)
decodeCompact BlockHeight
maxBits

computeAsertBits ::
  Integer ->
  Word32 ->
  Integer ->
  Integer ->
  Word32
computeAsertBits :: BlockWork -> BlockHeight -> BlockWork -> BlockWork -> BlockHeight
computeAsertBits BlockWork
halflife BlockHeight
anchor_bits BlockWork
time_diff BlockWork
height_diff =
  if BlockWork
e2 BlockWork -> BlockWork -> Bool
forall a. Ord a => a -> a -> Bool
>= BlockWork
0 Bool -> Bool -> Bool
&& BlockWork
e2 BlockWork -> BlockWork -> Bool
forall a. Ord a => a -> a -> Bool
< BlockWork
65536
    then
      if BlockWork
g4 BlockWork -> BlockWork -> Bool
forall a. Eq a => a -> a -> Bool
== BlockWork
0
        then BlockWork -> BlockHeight
encodeCompact BlockWork
1
        else
          if BlockWork
g4 BlockWork -> BlockWork -> Bool
forall a. Ord a => a -> a -> Bool
> BlockWork
maxTarget
            then BlockHeight
maxBits
            else BlockWork -> BlockHeight
encodeCompact BlockWork
g4
    else String -> BlockHeight
forall a. HasCallStack => String -> a
error (String -> BlockHeight) -> String -> BlockHeight
forall a b. (a -> b) -> a -> b
$ String
"Exponent not in range: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ BlockWork -> String
forall a. Show a => a -> String
show BlockWork
e2
  where
    g1 :: BlockWork
g1 = (BlockWork, Bool) -> BlockWork
forall a b. (a, b) -> a
fst (BlockHeight -> (BlockWork, Bool)
decodeCompact BlockHeight
anchor_bits)
    e1 :: BlockWork
e1 =
      ((BlockWork
time_diff BlockWork -> BlockWork -> BlockWork
forall a. Num a => a -> a -> a
- BlockWork
idealBlockTime BlockWork -> BlockWork -> BlockWork
forall a. Num a => a -> a -> a
* (BlockWork
height_diff BlockWork -> BlockWork -> BlockWork
forall a. Num a => a -> a -> a
+ BlockWork
1)) BlockWork -> BlockWork -> BlockWork
forall a. Num a => a -> a -> a
* BlockWork
radix)
        BlockWork -> BlockWork -> BlockWork
forall a. Integral a => a -> a -> a
`quot` BlockWork
halflife
    s :: BlockWork
s = BlockWork
e1 BlockWork -> Int -> BlockWork
forall a. Bits a => a -> Int -> a
`shiftR` Int
rBits
    e2 :: BlockWork
e2 = BlockWork
e1 BlockWork -> BlockWork -> BlockWork
forall a. Num a => a -> a -> a
- BlockWork
s BlockWork -> BlockWork -> BlockWork
forall a. Num a => a -> a -> a
* BlockWork
radix
    g2 :: BlockWork
g2 =
      BlockWork
g1
        BlockWork -> BlockWork -> BlockWork
forall a. Num a => a -> a -> a
* ( BlockWork
radix
              BlockWork -> BlockWork -> BlockWork
forall a. Num a => a -> a -> a
+ ( (BlockWork
195766423245049 BlockWork -> BlockWork -> BlockWork
forall a. Num a => a -> a -> a
* BlockWork
e2 BlockWork -> BlockWork -> BlockWork
forall a. Num a => a -> a -> a
+ BlockWork
971821376 BlockWork -> BlockWork -> BlockWork
forall a. Num a => a -> a -> a
* BlockWork
e2 BlockWork -> BlockWork -> BlockWork
forall a b. (Num a, Integral b) => a -> b -> a
^ BlockWork
2 BlockWork -> BlockWork -> BlockWork
forall a. Num a => a -> a -> a
+ BlockWork
5127 BlockWork -> BlockWork -> BlockWork
forall a. Num a => a -> a -> a
* BlockWork
e2 BlockWork -> BlockWork -> BlockWork
forall a b. (Num a, Integral b) => a -> b -> a
^ BlockWork
3 BlockWork -> BlockWork -> BlockWork
forall a. Num a => a -> a -> a
+ BlockWork
2 BlockWork -> BlockWork -> BlockWork
forall a b. (Num a, Integral b) => a -> b -> a
^ BlockWork
47)
                    BlockWork -> Int -> BlockWork
forall a. Bits a => a -> Int -> a
`shiftR` (Int
rBits Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
3)
                )
          )
    g3 :: BlockWork
g3 =
      if BlockWork
s BlockWork -> BlockWork -> Bool
forall a. Ord a => a -> a -> Bool
< BlockWork
0
        then BlockWork
g2 BlockWork -> Int -> BlockWork
forall a. Bits a => a -> Int -> a
`shiftR` Int -> Int
forall a. Num a => a -> a
negate (BlockWork -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral BlockWork
s)
        else BlockWork
g2 BlockWork -> Int -> BlockWork
forall a. Bits a => a -> Int -> a
`shiftL` BlockWork -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral BlockWork
s
    g4 :: BlockWork
g4 = BlockWork
g3 BlockWork -> Int -> BlockWork
forall a. Bits a => a -> Int -> a
`shiftR` Int
rBits

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

-- | Get suitable block for Bitcoin Cash DAA computation.
getSuitableBlock :: (BlockHeaders m) => BlockNode -> m BlockNode
getSuitableBlock :: forall (m :: * -> *). BlockHeaders m => BlockNode -> m BlockNode
getSuitableBlock BlockNode
par = do
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (BlockNode
par.height BlockHeight -> BlockHeight -> Bool
forall a. Ord a => a -> a -> Bool
>= BlockHeight
3) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> m ()
forall a. HasCallStack => String -> a
error String
"Block height is less than three"
  [BlockNode]
blocks <- (BlockNode
par BlockNode -> [BlockNode] -> [BlockNode]
forall a. a -> [a] -> [a]
:) ([BlockNode] -> [BlockNode]) -> m [BlockNode] -> m [BlockNode]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> BlockNode -> m [BlockNode]
forall (m :: * -> *).
BlockHeaders m =>
Int -> BlockNode -> m [BlockNode]
getParents Int
2 BlockNode
par
  BlockNode -> m BlockNode
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockNode -> m BlockNode) -> BlockNode -> m BlockNode
forall a b. (a -> b) -> a -> b
$ (BlockNode -> BlockNode -> Ordering) -> [BlockNode] -> [BlockNode]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (BlockHeight -> BlockHeight -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (BlockHeight -> BlockHeight -> Ordering)
-> (BlockNode -> BlockHeight) -> BlockNode -> BlockNode -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (.header.timestamp)) [BlockNode]
blocks [BlockNode] -> Int -> BlockNode
forall a. HasCallStack => [a] -> Int -> a
!! Int
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 :: forall (m :: * -> *).
BlockHeaders m =>
Network -> BlockNode -> BlockHeader -> m BlockHeight
nextPowWorkRequired Network
net BlockNode
par BlockHeader
bh
  | BlockNode
par.height BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
+ BlockHeight
1 BlockHeight -> BlockHeight -> BlockHeight
forall a. Integral a => a -> a -> a
`mod` Network -> BlockHeight
diffInterval Network
net BlockHeight -> BlockHeight -> Bool
forall a. Eq a => a -> a -> Bool
/= BlockHeight
0 =
      if Network
net.minDiffBlocks
        then
          if BlockHeight
ht BlockHeight -> BlockHeight -> Bool
forall a. Ord a => a -> a -> Bool
> BlockHeight
pt BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
+ BlockHeight
delta
            then BlockHeight -> m BlockHeight
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockHeight -> m BlockHeight) -> BlockHeight -> m BlockHeight
forall a b. (a -> b) -> a -> b
$ BlockWork -> BlockHeight
encodeCompact Network
net.powLimit
            else do
              BlockNode
d <- Network -> BlockNode -> m BlockNode
forall (m :: * -> *).
BlockHeaders m =>
Network -> BlockNode -> m BlockNode
lastNoMinDiff Network
net BlockNode
par
              BlockHeight -> m BlockHeight
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return BlockNode
d.header.bits
        else BlockHeight -> m BlockHeight
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return BlockNode
par.header.bits
  | Bool
otherwise = do
      let rh :: BlockHeight
rh = BlockNode
par.height BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
- Network -> BlockHeight
diffInterval Network
net BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
- BlockHeight
1
      BlockNode
a <- BlockNode -> Maybe BlockNode -> BlockNode
forall a. a -> Maybe a -> a
fromMaybe BlockNode
forall {a}. a
e1 (Maybe BlockNode -> BlockNode)
-> m (Maybe BlockNode) -> m BlockNode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockHeight -> BlockNode -> m (Maybe BlockNode)
forall (m :: * -> *).
BlockHeaders m =>
BlockHeight -> BlockNode -> m (Maybe BlockNode)
getAncestor BlockHeight
rh BlockNode
par
      let t :: BlockHeight
t = BlockNode
a.header.timestamp
      BlockHeight -> m BlockHeight
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockHeight -> m BlockHeight) -> BlockHeight -> m BlockHeight
forall a b. (a -> b) -> a -> b
$ Network -> BlockHeader -> BlockHeight -> BlockHeight
calcNextWork Network
net BlockNode
par.header BlockHeight
t
  where
    e1 :: a
e1 = String -> a
forall a. HasCallStack => String -> a
error String
"Could not get ancestor for block header"
    pt :: BlockHeight
pt = BlockNode
par.header.timestamp
    ht :: BlockHeight
ht = BlockHeader
bh.timestamp
    delta :: BlockHeight
delta = Network
net.targetSpacing BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
* BlockHeight
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 :: Network -> BlockHeader -> BlockHeight -> BlockHeight
calcNextWork Network
net BlockHeader
header BlockHeight
time
  | Network
net.powNoRetarget = BlockHeader
header.bits
  | BlockWork
new BlockWork -> BlockWork -> Bool
forall a. Ord a => a -> a -> Bool
> Network
net.powLimit = BlockWork -> BlockHeight
encodeCompact Network
net.powLimit
  | Bool
otherwise = BlockWork -> BlockHeight
encodeCompact BlockWork
new
  where
    s :: BlockHeight
s = BlockHeader
header.timestamp BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
- BlockHeight
time
    n :: BlockHeight
n
      | BlockHeight
s BlockHeight -> BlockHeight -> Bool
forall a. Ord a => a -> a -> Bool
< Network
net.targetTimespan BlockHeight -> BlockHeight -> BlockHeight
forall a. Integral a => a -> a -> a
`div` BlockHeight
4 = Network
net.targetTimespan BlockHeight -> BlockHeight -> BlockHeight
forall a. Integral a => a -> a -> a
`div` BlockHeight
4
      | BlockHeight
s BlockHeight -> BlockHeight -> Bool
forall a. Ord a => a -> a -> Bool
> Network
net.targetTimespan BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
* BlockHeight
4 = Network
net.targetTimespan BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
* BlockHeight
4
      | Bool
otherwise = BlockHeight
s
    l :: BlockWork
l = (BlockWork, Bool) -> BlockWork
forall a b. (a, b) -> a
fst ((BlockWork, Bool) -> BlockWork) -> (BlockWork, Bool) -> BlockWork
forall a b. (a -> b) -> a -> b
$ BlockHeight -> (BlockWork, Bool)
decodeCompact BlockHeader
header.bits
    new :: BlockWork
new = BlockWork
l BlockWork -> BlockWork -> BlockWork
forall a. Num a => a -> a -> a
* BlockHeight -> BlockWork
forall a b. (Integral a, Num b) => a -> b
fromIntegral BlockHeight
n BlockWork -> BlockWork -> BlockWork
forall a. Integral a => a -> a -> a
`div` BlockHeight -> BlockWork
forall a b. (Integral a, Num b) => a -> b
fromIntegral Network
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 :: Network -> BlockHeader -> Bool
isValidPOW Network
net BlockHeader
h
  | BlockWork
target BlockWork -> BlockWork -> Bool
forall a. Ord a => a -> a -> Bool
<= BlockWork
0 Bool -> Bool -> Bool
|| Bool
over Bool -> Bool -> Bool
|| BlockWork
target BlockWork -> BlockWork -> Bool
forall a. Ord a => a -> a -> Bool
> Network
net.powLimit = Bool
False
  | Bool
otherwise = BlockHash -> BlockWork
blockPOW (BlockHeader -> BlockHash
headerHash BlockHeader
h) BlockWork -> BlockWork -> Bool
forall a. Ord a => a -> a -> Bool
<= BlockWork -> BlockWork
forall a b. (Integral a, Num b) => a -> b
fromIntegral BlockWork
target
  where
    (BlockWork
target, Bool
over) = BlockHeight -> (BlockWork, Bool)
decodeCompact BlockHeader
h.bits

-- | Returns the proof of work of a block header hash as an 'Integer' number.
blockPOW :: BlockHash -> Integer
blockPOW :: BlockHash -> BlockWork
blockPOW = ByteString -> BlockWork
bsToInteger (ByteString -> BlockWork)
-> (BlockHash -> ByteString) -> BlockHash -> BlockWork
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
B.reverse (ByteString -> ByteString)
-> (BlockHash -> ByteString) -> BlockHash -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Put -> ByteString
runPutS (Put -> ByteString)
-> (BlockHash -> Put) -> BlockHash -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockHash -> Put
forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
forall (m :: * -> *). MonadPut m => BlockHash -> m ()
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 :: BlockHeader -> BlockWork
headerWork BlockHeader
bh = BlockWork
largestHash BlockWork -> BlockWork -> BlockWork
forall a. Integral a => a -> a -> a
`div` (BlockWork
target BlockWork -> BlockWork -> BlockWork
forall a. Num a => a -> a -> a
+ BlockWork
1)
  where
    target :: BlockWork
target = (BlockWork, Bool) -> BlockWork
forall a b. (a, b) -> a
fst ((BlockWork, Bool) -> BlockWork) -> (BlockWork, Bool) -> BlockWork
forall a b. (a -> b) -> a -> b
$ BlockHeight -> (BlockWork, Bool)
decodeCompact BlockHeader
bh.bits
    largestHash :: BlockWork
largestHash = BlockWork
1 BlockWork -> Int -> BlockWork
forall a. Bits a => a -> Int -> a
`shiftL` Int
256

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

-- | Compare two blocks to get the best.
chooseBest :: BlockNode -> BlockNode -> BlockNode
chooseBest :: BlockNode -> BlockNode -> BlockNode
chooseBest BlockNode
b1 BlockNode
b2
  | BlockNode
b1.work BlockWork -> BlockWork -> Bool
forall a. Eq a => a -> a -> Bool
== BlockNode
b2.work =
      if BlockNode
b1.height BlockHeight -> BlockHeight -> Bool
forall a. Ord a => a -> a -> Bool
>= BlockNode
b2.height
        then BlockNode
b1
        else BlockNode
b2
  | BlockNode
b1.work BlockWork -> BlockWork -> Bool
forall a. Ord a => a -> a -> Bool
> BlockNode
b2.work = BlockNode
b1
  | Bool
otherwise = BlockNode
b2

-- | Get list of blocks for a block locator.
blockLocatorNodes :: (BlockHeaders m) => BlockNode -> m [BlockNode]
blockLocatorNodes :: forall (m :: * -> *). BlockHeaders m => BlockNode -> m [BlockNode]
blockLocatorNodes BlockNode
best =
  [BlockNode] -> [BlockNode]
forall a. [a] -> [a]
reverse ([BlockNode] -> [BlockNode]) -> m [BlockNode] -> m [BlockNode]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [BlockNode] -> BlockNode -> BlockHeight -> m [BlockNode]
forall {m :: * -> *}.
BlockHeaders m =>
[BlockNode] -> BlockNode -> BlockHeight -> m [BlockNode]
go [] BlockNode
best BlockHeight
1
  where
    e1 :: a
e1 = String -> a
forall a. HasCallStack => String -> a
error String
"Could not get ancestor"
    go :: [BlockNode] -> BlockNode -> BlockHeight -> m [BlockNode]
go [BlockNode]
loc BlockNode
bn BlockHeight
n =
      let loc' :: [BlockNode]
loc' = BlockNode
bn BlockNode -> [BlockNode] -> [BlockNode]
forall a. a -> [a] -> [a]
: [BlockNode]
loc
          n' :: BlockHeight
n' =
            if [BlockNode] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BlockNode]
loc' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10
              then BlockHeight
n BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
* BlockHeight
2
              else BlockHeight
1
       in if BlockNode
bn.height BlockHeight -> BlockHeight -> Bool
forall a. Ord a => a -> a -> Bool
< BlockHeight
n'
            then do
              BlockNode
a <- BlockNode -> Maybe BlockNode -> BlockNode
forall a. a -> Maybe a -> a
fromMaybe BlockNode
forall {a}. a
e1 (Maybe BlockNode -> BlockNode)
-> m (Maybe BlockNode) -> m BlockNode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockHeight -> BlockNode -> m (Maybe BlockNode)
forall (m :: * -> *).
BlockHeaders m =>
BlockHeight -> BlockNode -> m (Maybe BlockNode)
getAncestor BlockHeight
0 BlockNode
bn
              [BlockNode] -> m [BlockNode]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([BlockNode] -> m [BlockNode]) -> [BlockNode] -> m [BlockNode]
forall a b. (a -> b) -> a -> b
$ BlockNode
a BlockNode -> [BlockNode] -> [BlockNode]
forall a. a -> [a] -> [a]
: [BlockNode]
loc'
            else do
              let h :: BlockHeight
h = BlockNode
bn.height BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
- BlockHeight
n'
              BlockNode
bn' <- BlockNode -> Maybe BlockNode -> BlockNode
forall a. a -> Maybe a -> a
fromMaybe BlockNode
forall {a}. a
e1 (Maybe BlockNode -> BlockNode)
-> m (Maybe BlockNode) -> m BlockNode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockHeight -> BlockNode -> m (Maybe BlockNode)
forall (m :: * -> *).
BlockHeaders m =>
BlockHeight -> BlockNode -> m (Maybe BlockNode)
getAncestor BlockHeight
h BlockNode
bn
              [BlockNode] -> BlockNode -> BlockHeight -> m [BlockNode]
go [BlockNode]
loc' BlockNode
bn' BlockHeight
n'

-- | Get block locator.
blockLocator :: (BlockHeaders m) => BlockNode -> m BlockLocator
blockLocator :: forall (m :: * -> *). BlockHeaders m => BlockNode -> m BlockLocator
blockLocator BlockNode
bn = (BlockNode -> BlockHash) -> [BlockNode] -> BlockLocator
forall a b. (a -> b) -> [a] -> [b]
map (BlockHeader -> BlockHash
headerHash (BlockHeader -> BlockHash)
-> (BlockNode -> BlockHeader) -> BlockNode -> BlockHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.header)) ([BlockNode] -> BlockLocator) -> m [BlockNode] -> m BlockLocator
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockNode -> m [BlockNode]
forall (m :: * -> *). BlockHeaders m => BlockNode -> m [BlockNode]
blockLocatorNodes BlockNode
bn

-- | Become rich beyond your wildest dreams.
mineBlock :: Network -> Word32 -> BlockHeader -> BlockHeader
mineBlock :: Network -> BlockHeight -> BlockHeader -> BlockHeader
mineBlock Network
net BlockHeight
seed BlockHeader
h =
  [BlockHeader] -> BlockHeader
forall a. HasCallStack => [a] -> a
head
    [ BlockHeader
j
      | BlockHeight
i <- (BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
+ BlockHeight
seed) (BlockHeight -> BlockHeight) -> [BlockHeight] -> [BlockHeight]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [BlockHeight
0 .. BlockHeight
forall a. Bounded a => a
maxBound],
        let j :: BlockHeader
j = BlockHeader
h {nonce = i},
        Network -> BlockHeader -> Bool
isValidPOW Network
net BlockHeader
j
    ]

-- | Generate and append new blocks (mining). Only practical in regtest network.
appendBlocks ::
  Network ->
  -- | random seed
  Word32 ->
  BlockHeader ->
  Int ->
  [BlockHeader]
appendBlocks :: Network -> BlockHeight -> BlockHeader -> Int -> [BlockHeader]
appendBlocks Network
_ BlockHeight
_ BlockHeader
_ Int
0 = []
appendBlocks Network
net BlockHeight
seed BlockHeader
bh Int
i =
  BlockHeader
bh' BlockHeader -> [BlockHeader] -> [BlockHeader]
forall a. a -> [a] -> [a]
: Network -> BlockHeight -> BlockHeader -> Int -> [BlockHeader]
appendBlocks Network
net BlockHeight
seed BlockHeader
bh' (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
  where
    bh' :: BlockHeader
bh' =
      Network -> BlockHeight -> BlockHeader -> BlockHeader
mineBlock
        Network
net
        BlockHeight
seed
        BlockHeader
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 :: forall (m :: * -> *).
BlockHeaders m =>
BlockNode -> BlockNode -> m BlockNode
splitPoint BlockNode
l BlockNode
r = do
  let h :: BlockHeight
h = BlockHeight -> BlockHeight -> BlockHeight
forall a. Ord a => a -> a -> a
min BlockNode
l.height BlockNode
r.height
  BlockNode
ll <- BlockNode -> Maybe BlockNode -> BlockNode
forall a. a -> Maybe a -> a
fromMaybe BlockNode
forall {a}. a
e (Maybe BlockNode -> BlockNode)
-> m (Maybe BlockNode) -> m BlockNode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockHeight -> BlockNode -> m (Maybe BlockNode)
forall (m :: * -> *).
BlockHeaders m =>
BlockHeight -> BlockNode -> m (Maybe BlockNode)
getAncestor BlockHeight
h BlockNode
l
  BlockNode
lr <- BlockNode -> Maybe BlockNode -> BlockNode
forall a. a -> Maybe a -> a
fromMaybe BlockNode
forall {a}. a
e (Maybe BlockNode -> BlockNode)
-> m (Maybe BlockNode) -> m BlockNode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockHeight -> BlockNode -> m (Maybe BlockNode)
forall (m :: * -> *).
BlockHeaders m =>
BlockHeight -> BlockNode -> m (Maybe BlockNode)
getAncestor BlockHeight
h BlockNode
r
  BlockNode -> BlockNode -> m BlockNode
forall (m :: * -> *).
BlockHeaders m =>
BlockNode -> BlockNode -> m BlockNode
f BlockNode
ll BlockNode
lr
  where
    e :: a
e = String -> a
forall a. HasCallStack => String -> a
error String
"BUG: Could not get ancestor at lowest height"
    f :: BlockNode -> BlockNode -> m BlockNode
f BlockNode
ll BlockNode
lr =
      if BlockNode
ll BlockNode -> BlockNode -> Bool
forall a. Eq a => a -> a -> Bool
== BlockNode
lr
        then BlockNode -> m BlockNode
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return BlockNode
lr
        else do
          let h :: BlockHeight
h = BlockNode
ll.height BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
- BlockHeight
1
          BlockNode
pl <- BlockNode -> Maybe BlockNode -> BlockNode
forall a. a -> Maybe a -> a
fromMaybe BlockNode
forall {a}. a
e (Maybe BlockNode -> BlockNode)
-> m (Maybe BlockNode) -> m BlockNode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockHeight -> BlockNode -> m (Maybe BlockNode)
forall (m :: * -> *).
BlockHeaders m =>
BlockHeight -> BlockNode -> m (Maybe BlockNode)
getAncestor BlockHeight
h BlockNode
ll
          BlockNode
pr <- BlockNode -> Maybe BlockNode -> BlockNode
forall a. a -> Maybe a -> a
fromMaybe BlockNode
forall {a}. a
e (Maybe BlockNode -> BlockNode)
-> m (Maybe BlockNode) -> m BlockNode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockHeight -> BlockNode -> m (Maybe BlockNode)
forall (m :: * -> *).
BlockHeaders m =>
BlockHeight -> BlockNode -> m (Maybe BlockNode)
getAncestor BlockHeight
h BlockNode
lr
          BlockNode -> BlockNode -> m BlockNode
f BlockNode
pl BlockNode
pr

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

-- | Compute block subsidy at particular height.
computeSubsidy :: Network -> BlockHeight -> Word64
computeSubsidy :: Network -> BlockHeight -> Word64
computeSubsidy Network
net BlockHeight
height =
  let halvings :: BlockHeight
halvings = BlockHeight
height BlockHeight -> BlockHeight -> BlockHeight
forall a. Integral a => a -> a -> a
`div` Network
net.halvingInterval
      ini :: Word64
ini = Word64
50 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
100 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
1000 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
1000
   in if BlockHeight
halvings BlockHeight -> BlockHeight -> Bool
forall a. Ord a => a -> a -> Bool
>= BlockHeight
64
        then Word64
0
        else Word64
ini Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` BlockHeight -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral BlockHeight
halvings