haskoin-core-1.2.2: src/Haskoin/Block/Headers.hs
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoFieldSelectors #-}
-- |
-- Module : Haskoin.Block.Headers
-- Copyright : No rights reserved
-- License : MIT
-- Maintainer : jprupp@protonmail.ch
-- Stability : experimental
-- Portability : POSIX
--
-- Block chain header synchronization and proof-of-work consensus functions.
module Haskoin.Block.Headers
( -- * Block Headers
BlockNode (..),
BlockHeaders (..),
BlockWork,
genesisNode,
genesisBlock,
isGenesis,
chooseBest,
-- ** Header Store
parentBlock,
getParents,
getAncestor,
splitPoint,
connectBlocks,
connectBlock,
blockLocator,
-- ** Header Memory Store
HeaderMemory (..),
ShortBlockHash,
BlockMap,
shortBlockHash,
initialChain,
genesisMap,
-- ** Helper Functions
appendBlocks,
validBlock,
validCP,
afterLastCP,
bip34,
validVersion,
lastNoMinDiff,
nextWorkRequired,
nextEdaWorkRequired,
nextDaaWorkRequired,
nextAsertWorkRequired,
computeAsertBits,
computeTarget,
getSuitableBlock,
nextPowWorkRequired,
calcNextWork,
isValidPOW,
blockPOW,
headerWork,
diffInterval,
blockLocatorNodes,
mineBlock,
computeSubsidy,
mtp,
firstGreaterOrEqual,
lastSmallerOrEqual,
)
where
import Control.Applicative ((<|>))
import Control.DeepSeq
import Control.Monad (guard, mzero, unless, when)
import Control.Monad.Except (ExceptT (..), runExceptT, throwError)
import Control.Monad.State.Strict as State (StateT, get, gets, lift, modify)
import Control.Monad.Trans.Maybe
import Data.Binary (Binary (..))
import Data.Bits (shiftL, shiftR, (.&.))
import Data.ByteString qualified as B
import Data.ByteString.Short (ShortByteString, fromShort, toShort)
import Data.Bytes.Get
import Data.Bytes.Put
import Data.Bytes.Serial
import Data.Function (on)
import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as HashMap
import Data.Hashable
import Data.List (sort, sortBy)
import Data.Maybe (fromMaybe, listToMaybe)
import Data.Serialize (Serialize (..))
import Data.Typeable (Typeable)
import Data.Word (Word32, Word64)
import GHC.Generics (Generic)
import Haskoin.Block.Common
import Haskoin.Crypto
import Haskoin.Network.Data
import Haskoin.Transaction.Genesis
import Haskoin.Util
-- | Short version of the block hash. Uses the good end of the hash (the part
-- that doesn't have a long string of zeroes).
type ShortBlockHash = Word64
-- | Memory-based map to a serialized 'BlockNode' data structure.
-- 'ShortByteString' is used to avoid memory fragmentation and make the data
-- structure compact.
type BlockMap = HashMap ShortBlockHash ShortByteString
-- | Represents accumulated work in the block chain so far.
type BlockWork = Integer
-- | Data structure representing a block header and its position in the
-- block chain.
data BlockNode = BlockNode
{ header :: !BlockHeader,
height :: !BlockHeight,
-- | accumulated work so far
work :: !BlockWork,
-- | skip magic block hash
skip :: !BlockHash
}
deriving (Show, Read, Generic, Hashable, NFData)
instance Serial BlockNode where
deserialize = do
header <- deserialize
height <- getWord32le
work <- getInteger
if height == 0
then do
let skip = headerHash header
return BlockNode {..}
else do
skip <- deserialize
return BlockNode {..}
serialize bn = do
serialize $ bn.header
putWord32le $ bn.height
putInteger $ bn.work
case bn.height of
0 -> return ()
_ -> serialize $ bn.skip
instance Serialize BlockNode where
put = serialize
get = deserialize
instance Binary BlockNode where
put = serialize
get = deserialize
instance Eq BlockNode where
(==) = (==) `on` (.header)
instance Ord BlockNode where
compare = compare `on` (.height)
-- | Memory-based header tree.
data HeaderMemory = HeaderMemory
{ blocks :: !BlockMap,
best :: !BlockNode
}
deriving (Eq, Typeable, Show, Read, Generic, Hashable, NFData)
-- | Typeclass for block header chain storage monad.
class (Monad m) => BlockHeaders m where
-- | Add a new 'BlockNode' to the chain. Does not validate.
addBlockHeader :: BlockNode -> m ()
-- | Get a 'BlockNode' associated with a 'BlockHash'.
getBlockHeader :: BlockHash -> m (Maybe BlockNode)
-- | Locate the 'BlockNode' for the highest block in the chain
getBestBlockHeader :: m BlockNode
-- | Set the highest block in the chain.
setBestBlockHeader :: BlockNode -> m ()
-- | Add a continuous bunch of block headers the chain. Does not validate.
addBlockHeaders :: [BlockNode] -> m ()
addBlockHeaders = mapM_ addBlockHeader
instance (Monad m) => BlockHeaders (StateT HeaderMemory m) where
addBlockHeader = modify . addBlockHeaderMemory
getBlockHeader bh = getBlockHeaderMemory bh <$> State.get
getBestBlockHeader = gets (.best)
setBestBlockHeader bn = modify $ \s -> s {best = bn}
-- | Initialize memory-based chain.
initialChain :: Network -> HeaderMemory
initialChain net =
HeaderMemory
{ blocks = genesisMap net,
best = genesisNode net
}
-- | Initialize map for memory-based chain.
genesisMap :: Network -> BlockMap
genesisMap net =
HashMap.singleton
(shortBlockHash (headerHash net.genesisHeader))
(toShort (runPutS (serialize (genesisNode net))))
-- | Add block header to memory block map.
addBlockHeaderMemory :: BlockNode -> HeaderMemory -> HeaderMemory
addBlockHeaderMemory bn s = s {blocks = addBlockToMap bn s.blocks}
-- | Get block header from memory block map.
getBlockHeaderMemory :: BlockHash -> HeaderMemory -> Maybe BlockNode
getBlockHeaderMemory bh s = do
bs <- shortBlockHash bh `HashMap.lookup` s.blocks
eitherToMaybe . runGetS deserialize $ fromShort bs
-- | Calculate short block hash taking eight non-zero bytes from the 16-byte
-- hash. This function will take the bytes that are not on the zero-side of the
-- hash, making colissions between short block hashes difficult.
shortBlockHash :: BlockHash -> ShortBlockHash
shortBlockHash =
either error id . runGetS deserialize . B.take 8 . runPutS . serialize
-- | Add a block to memory-based block map.
addBlockToMap :: BlockNode -> BlockMap -> BlockMap
addBlockToMap node =
HashMap.insert
(shortBlockHash $ headerHash $ node.header)
(toShort $ runPutS $ serialize node)
-- | Get the ancestor of the provided 'BlockNode' at the specified
-- 'BlockHeight'.
getAncestor ::
(BlockHeaders m) =>
BlockHeight ->
BlockNode ->
m (Maybe BlockNode)
getAncestor height node
| height > node.height = return Nothing
| otherwise = go node
where
e1 = error "Could not get current walk skip"
e2 = error "Could not get previous walk skip"
go walk
| walk.height > height =
let height_b = skipHeight (walk.height)
height_a = skipHeight (walk.height - 1)
not_genesis = not (isGenesis walk)
is_b = height_b == height
below_b = height_b > height
at_or_below_a = height <= height_a
far_enough = height_b - 2 > height_a && at_or_below_a
recurse_b = below_b && not far_enough
cond = not_genesis && (is_b || recurse_b)
in if cond
then do
walk' <- fromMaybe e1 <$> getBlockHeader walk.skip
go walk'
else do
walk' <- fromMaybe e2 <$> getBlockHeader walk.header.prev
go walk'
| otherwise = return $ Just walk
-- | Is the provided 'BlockNode' the Genesis block?
isGenesis :: BlockNode -> Bool
isGenesis BlockNode {height = 0} = True
isGenesis _ = False
-- | Build the genesis 'BlockNode' for the supplied 'Network'.
genesisNode :: Network -> BlockNode
genesisNode net =
BlockNode
{ header = net.genesisHeader,
height = 0,
work = headerWork net.genesisHeader,
skip = headerHash net.genesisHeader
}
-- | Validate a list of continuous block headers and import them to the
-- block chain. Return 'Left' on failure with error information.
connectBlocks ::
(BlockHeaders m) =>
Network ->
-- | current time
Timestamp ->
[BlockHeader] ->
m (Either String [BlockNode])
connectBlocks _ _ [] = return $ Right []
connectBlocks net t bhs@(bh : _) =
runExceptT $ do
unless (chained bhs) $
throwError "Blocks to connect do not form a chain"
par <-
maybeToExceptT
"Could not get parent block"
(MaybeT (parentBlock bh))
pars <- lift $ getParents 10 par
bb <- lift getBestBlockHeader
go par [] bb par pars bhs >>= \case
bns@(bn : _) -> do
lift $ addBlockHeaders bns
let bb' = chooseBest bn bb
when (bb' /= bb) $ lift $ setBestBlockHeader bb'
return bns
_ -> undefined
where
chained (h1 : h2 : hs) = headerHash h1 == h2.prev && chained (h2 : hs)
chained _ = True
skipit lbh ls par
| sh == lbh.height = return lbh
| sh < lbh.height = do
skM <- lift $ getAncestor sh lbh
case skM of
Just sk -> return sk
Nothing ->
throwError $
"BUG: Could not get skip for block "
++ show (headerHash $ par.header)
| otherwise = do
let sn = ls !! fromIntegral (par.height - sh)
when (sn.height /= sh) $
throwError "BUG: Node height not right in skip"
return sn
where
sh = skipHeight (par.height + 1)
go _ acc _ _ _ [] = return acc
go lbh acc bb par pars (h : hs) = do
sk <- skipit lbh acc par
bn <- ExceptT . return $ validBlock net t bb par pars h sk
go lbh (bn : acc) (chooseBest bn bb) bn (take 10 $ par : pars) hs
-- | Block's parent. If the block header is in the store, its parent must also
-- be there. No block header get deleted or pruned from the store.
parentBlock ::
(BlockHeaders m) =>
BlockHeader ->
m (Maybe BlockNode)
parentBlock = getBlockHeader . (.prev)
-- | Validate and connect single block header to the block chain. Return 'Left'
-- if fails to be validated.
connectBlock ::
(BlockHeaders m) =>
Network ->
-- | current time
Timestamp ->
BlockHeader ->
m (Either String BlockNode)
connectBlock net t bh =
runExceptT $ do
par <-
maybeToExceptT
"Could not get parent block"
(MaybeT (parentBlock bh))
pars <- lift $ getParents 10 par
skM <- lift $ getAncestor (skipHeight (par.height + 1)) par
sk <-
case skM of
Just sk -> return sk
Nothing ->
throwError $
"BUG: Could not get skip for block "
++ show (headerHash $ par.header)
bb <- lift getBestBlockHeader
bn <- ExceptT . return $ validBlock net t bb par pars bh sk
let bb' = chooseBest bb bn
lift $ addBlockHeader bn
when (bb /= bb') . lift $ setBestBlockHeader bb'
return bn
-- | Validate this block header. Build a 'BlockNode' if successful.
validBlock ::
Network ->
-- | current time
Timestamp ->
-- | best block
BlockNode ->
-- | immediate parent
BlockNode ->
-- | 10 parents above
[BlockNode] ->
-- | header to validate
BlockHeader ->
-- | skip node (black magic)
BlockNode ->
Either String BlockNode
validBlock net t bb par pars bh sk = do
let mt = medianTime . map (.header.timestamp) $ par : pars
nt = bh.timestamp
hh = headerHash bh
nv = bh.version
ng = par.height + 1
aw = par.work + headerWork bh
unless (isValidPOW net bh) $
Left $
"Proof of work failed: " ++ show (headerHash bh)
unless (nt <= t + 2 * 60 * 60) $
Left $
"Invalid header timestamp: " ++ show nt
unless (nt >= mt) $
Left $
"Block timestamp too early: " ++ show nt
unless (afterLastCP net (bb.height) ng) $
Left $
"Rewriting pre-checkpoint chain: " ++ show ng
unless (validCP net ng hh) $
Left $
"Rejected checkpoint: " ++ show ng
unless (bip34 net ng hh) $
Left $
"Rejected BIP-34 block: " ++ show hh
unless (validVersion net ng nv) $
Left $
"Invalid block version: " ++ show nv
return
BlockNode
{ header = bh,
height = ng,
work = aw,
skip = headerHash sk.header
}
-- | Return the median of all provided timestamps. Can be unsorted. Error on
-- empty list.
medianTime :: [Timestamp] -> Timestamp
medianTime ts
| null ts = error "Cannot compute median time of empty header list"
| otherwise = sort ts !! (length ts `div` 2)
-- | Calculate the height of the skip (magic) block that corresponds to the
-- given height. The block hash of the ancestor at that height will be placed on
-- the 'BlockNode' structure to help locate ancestors at any height quickly.
skipHeight :: BlockHeight -> BlockHeight
skipHeight height
| height < 2 = 0
| height .&. 1 /= 0 = invertLowestOne (invertLowestOne $ height - 1) + 1
| otherwise = invertLowestOne height
-- | Part of the skip black magic calculation.
invertLowestOne :: BlockHeight -> BlockHeight
invertLowestOne height = height .&. (height - 1)
-- | Get a number of parents for the provided block.
getParents ::
(BlockHeaders m) =>
Int ->
BlockNode ->
-- | starts from immediate parent
m [BlockNode]
getParents = getpars []
where
getpars acc 0 _ = return $ reverse acc
getpars acc n BlockNode {..}
| height == 0 = return $ reverse acc
| otherwise = do
parM <- getBlockHeader header.prev
case parM of
Just bn -> getpars (bn : acc) (n - 1) bn
Nothing -> error "BUG: All non-genesis blocks should have a parent"
-- | Verify that checkpoint location is valid.
validCP ::
Network ->
-- | new child height
BlockHeight ->
-- | new child hash
BlockHash ->
Bool
validCP net height newChildHash =
case lookup height net.checkpoints of
Just cpHash -> cpHash == newChildHash
Nothing -> True
-- | New block height above the last checkpoint imported. Used to prevent a
-- reorg below the highest checkpoint that was already imported.
afterLastCP ::
Network ->
-- | best height
BlockHeight ->
-- | new imported block height
BlockHeight ->
Bool
afterLastCP net bestHeight newChildHeight =
case lM of
Just l -> l < newChildHeight
Nothing -> True
where
lM =
listToMaybe . reverse $
[c | (c, _) <- net.checkpoints, c <= bestHeight]
-- | This block should be at least version 2 (BIP34). Block height must be
-- included in the coinbase transaction to prevent non-unique transaction
-- hashes.
bip34 ::
Network ->
-- | new child height
BlockHeight ->
-- | new child hash
BlockHash ->
Bool
bip34 net height hsh
| fst net.bip34Block == 0 = True
| fst net.bip34Block == height = snd net.bip34Block == hsh
| otherwise = True
-- | Check if the provided block height and version are valid.
validVersion ::
Network ->
-- | new child height
BlockHeight ->
-- | new child version
Word32 ->
Bool
validVersion net height version
| version < 2 = height < fst net.bip34Block
| version < 3 = height < net.bip66Height
| version < 4 = height < net.bip65Height
| otherwise = True
-- | Find last block with normal, as opposed to minimum difficulty (for test
-- networks).
lastNoMinDiff :: (BlockHeaders m) => Network -> BlockNode -> m BlockNode
lastNoMinDiff _ bn@BlockNode {height = 0} = return bn
lastNoMinDiff net bn = do
let i = bn.height `mod` diffInterval net /= 0
c = encodeCompact net.powLimit
l = bn.header.bits == c
e1 =
error $
"Could not get block header for parent of "
++ show (headerHash bn.header)
if i && l
then do
bn' <- fromMaybe e1 <$> getBlockHeader (bn.header.prev)
lastNoMinDiff net bn'
else return bn
-- | Returns the work required on a block header given the previous block. This
-- coresponds to @bitcoind@ function @GetNextWorkRequired@ in @main.cpp@.
nextWorkRequired ::
(BlockHeaders m) =>
Network ->
BlockNode ->
BlockHeader ->
m Word32
nextWorkRequired net par bh = do
ma <- getAsertAnchor net
case asert ma <|> daa <|> eda <|> pow of
Just f -> f par bh
Nothing -> error "Could not determine difficulty algorithm"
where
asert ma = do
anchor <- ma
guard (par.height > anchor.height)
return $ nextAsertWorkRequired net anchor
daa = do
daa_height <- net.daaHeight
guard (par.height + 1 >= daa_height)
return $ nextDaaWorkRequired net
eda = do
eda_height <- net.edaHeight
guard (par.height + 1 >= eda_height)
return $ nextEdaWorkRequired net
pow = return $ nextPowWorkRequired net
-- | Find out the next amount of work required according to the Emergency
-- Difficulty Adjustment (EDA) algorithm from Bitcoin Cash.
nextEdaWorkRequired ::
(BlockHeaders m) => Network -> BlockNode -> BlockHeader -> m Word32
nextEdaWorkRequired net par bh
| par.height + 1 `mod` diffInterval net == 0 =
nextWorkRequired net par bh
| mindiff = return (encodeCompact net.powLimit)
| par.header.bits == encodeCompact net.powLimit =
return (encodeCompact net.powLimit)
| otherwise = do
par6 <- fromMaybe e1 <$> getAncestor (par.height - 6) par
pars <- getParents 10 par
pars6 <- getParents 10 par6
let par6med =
medianTime $ map (.header.timestamp) (par6 : pars6)
parmed = medianTime $ map (.header.timestamp) (par : pars)
mtp6 = parmed - par6med
if mtp6 < 12 * 3600
then return $ par.header.bits
else
return $
let (diff, _) = decodeCompact par.header.bits
ndiff = diff + (diff `shiftR` 2)
in if net.powLimit > ndiff
then encodeCompact net.powLimit
else encodeCompact ndiff
where
mindiff = bh.timestamp > par.header.timestamp + net.targetSpacing * 2
e1 = error "Could not get seventh ancestor of block"
-- | Find the next amount of work required according to the Difficulty
-- Adjustment Algorithm (DAA) from Bitcoin Cash.
nextDaaWorkRequired ::
(BlockHeaders m) => Network -> BlockNode -> BlockHeader -> m Word32
nextDaaWorkRequired net par bh
| mindiff = return (encodeCompact net.powLimit)
| otherwise = do
unless (par.height >= diffInterval net) $
error "Block height below difficulty interval"
l <- getSuitableBlock par
par144 <- fromMaybe e1 <$> getAncestor (par.height - 144) par
f <- getSuitableBlock par144
let nextTarget = computeTarget net f l
if nextTarget > net.powLimit
then return $ encodeCompact net.powLimit
else return $ encodeCompact nextTarget
where
e1 = error "Cannot get ancestor at parent - 144 height"
mindiff = bh.timestamp > par.header.timestamp + net.targetSpacing * 2
mtp :: (BlockHeaders m) => BlockNode -> m Timestamp
mtp bn
| bn.height == 0 = return 0
| otherwise = do
pars <- getParents 11 bn
return $ medianTime (map (.header.timestamp) pars)
firstGreaterOrEqual ::
(BlockHeaders m) =>
Network ->
(BlockNode -> m Ordering) ->
m (Maybe BlockNode)
firstGreaterOrEqual = binSearch False
lastSmallerOrEqual ::
(BlockHeaders m) =>
Network ->
(BlockNode -> m Ordering) ->
m (Maybe BlockNode)
lastSmallerOrEqual = binSearch True
binSearch ::
(BlockHeaders m) =>
Bool ->
Network ->
(BlockNode -> m Ordering) ->
m (Maybe BlockNode)
binSearch top net f = runMaybeT $ do
(a, b) <- lift $ extremes net
go a b
where
go a b = do
m <- lift $ middleBlock a b
a' <- lift $ f a
b' <- lift $ f b
m' <- lift $ f m
r (a, a') (b, b') (m, m')
r (a, a') (b, b') (m, m')
| out_of_bounds a' b' = mzero
| select_first a' = return a
| select_last b' = return b
| no_middle a b = choose_one a b
| is_between a' m' = go a m
| is_between m' b' = go m b
| otherwise = mzero
select_first a'
| not top = a' /= LT
| otherwise = False
select_last b'
| top = b' /= GT
| otherwise = False
out_of_bounds a' b'
| top = a' == GT
| otherwise = b' == LT
no_middle a b = b.height - a.height <= 1
is_between a' b' = a' /= GT && b' /= LT
choose_one a b
| top = return a
| otherwise = return b
extremes :: (BlockHeaders m) => Network -> m (BlockNode, BlockNode)
extremes net = do
b <- getBestBlockHeader
return (genesisNode net, b)
middleBlock :: (BlockHeaders m) => BlockNode -> BlockNode -> m BlockNode
middleBlock a b =
getAncestor h b >>= \case
Nothing -> error "You fell into a pit full of mud and snakes"
Just x -> return x
where
h = middleOf a.height b.height
middleOf :: (Integral a) => a -> a -> a
middleOf a b = a + ((b - a) `div` 2)
-- TODO: Use known anchor after fork
getAsertAnchor :: (BlockHeaders m) => Network -> m (Maybe BlockNode)
getAsertAnchor net =
case net.asertActivationTime of
Nothing -> return Nothing
Just act -> firstGreaterOrEqual net (f act)
where
f act bn = do
m <- mtp bn
return $ compare m act
-- | Find the next amount of work required according to the aserti3-2d algorithm.
nextAsertWorkRequired ::
(BlockHeaders m) =>
Network ->
BlockNode ->
BlockNode ->
BlockHeader ->
m Word32
nextAsertWorkRequired net anchor par bh = do
anchor_parent <-
fromMaybe e_fork <$> getBlockHeader anchor.header.prev
let anchor_parent_time = toInteger anchor_parent.header.timestamp
time_diff = current_time - anchor_parent_time
return $ computeAsertBits halflife anchor_bits time_diff height_diff
where
halflife = net.asertHalfLife
anchor_height = toInteger anchor.height
anchor_bits = anchor.header.bits
current_height = toInteger par.height + 1
height_diff = current_height - anchor_height
current_time = toInteger bh.timestamp
e_fork = error "Could not get fork block header"
idealBlockTime :: Integer
idealBlockTime = 10 * 60
rBits :: Int
rBits = 16
radix :: Integer
radix = 1 `shiftL` rBits
maxBits :: Word32
maxBits = 0x1d00ffff
maxTarget :: Integer
maxTarget = fst $ decodeCompact maxBits
computeAsertBits ::
Integer ->
Word32 ->
Integer ->
Integer ->
Word32
computeAsertBits halflife anchor_bits time_diff height_diff =
if e2 >= 0 && e2 < 65536
then
if g4 == 0
then encodeCompact 1
else
if g4 > maxTarget
then maxBits
else encodeCompact g4
else error $ "Exponent not in range: " ++ show e2
where
g1 = fst (decodeCompact anchor_bits)
e1 =
((time_diff - idealBlockTime * (height_diff + 1)) * radix)
`quot` halflife
s = e1 `shiftR` rBits
e2 = e1 - s * radix
g2 =
g1
* ( radix
+ ( (195766423245049 * e2 + 971821376 * e2 ^ 2 + 5127 * e2 ^ 3 + 2 ^ 47)
`shiftR` (rBits * 3)
)
)
g3 =
if s < 0
then g2 `shiftR` negate (fromIntegral s)
else g2 `shiftL` fromIntegral s
g4 = g3 `shiftR` rBits
-- | Compute Bitcoin Cash DAA target for a new block.
computeTarget :: Network -> BlockNode -> BlockNode -> Integer
computeTarget net f l =
let work = (l.work - f.work) * fromIntegral net.targetSpacing
tspan = l.header.timestamp - f.header.timestamp
tspan'
| tspan > 288 * net.targetSpacing =
288 * net.targetSpacing
| tspan < 72 * net.targetSpacing =
72 * net.targetSpacing
| otherwise = tspan
work' = work `div` fromIntegral tspan'
in 2 ^ (256 :: Integer) `div` work'
-- | Get suitable block for Bitcoin Cash DAA computation.
getSuitableBlock :: (BlockHeaders m) => BlockNode -> m BlockNode
getSuitableBlock par = do
unless (par.height >= 3) $ error "Block height is less than three"
blocks <- (par :) <$> getParents 2 par
return $ sortBy (compare `on` (.header.timestamp)) blocks !! 1
-- | Returns the work required on a block header given the previous block. This
-- coresponds to bitcoind function GetNextWorkRequired in main.cpp.
nextPowWorkRequired ::
(BlockHeaders m) => Network -> BlockNode -> BlockHeader -> m Word32
nextPowWorkRequired net par bh
| par.height + 1 `mod` diffInterval net /= 0 =
if net.minDiffBlocks
then
if ht > pt + delta
then return $ encodeCompact net.powLimit
else do
d <- lastNoMinDiff net par
return d.header.bits
else return par.header.bits
| otherwise = do
let rh = par.height - diffInterval net - 1
a <- fromMaybe e1 <$> getAncestor rh par
let t = a.header.timestamp
return $ calcNextWork net par.header t
where
e1 = error "Could not get ancestor for block header"
pt = par.header.timestamp
ht = bh.timestamp
delta = net.targetSpacing * 2
-- | Computes the work required for the first block in a new retarget period.
calcNextWork ::
Network ->
-- | last block in previous retarget (parent)
BlockHeader ->
-- | timestamp of first block in previous retarget
Timestamp ->
Word32
calcNextWork net header time
| net.powNoRetarget = header.bits
| new > net.powLimit = encodeCompact net.powLimit
| otherwise = encodeCompact new
where
s = header.timestamp - time
n
| s < net.targetTimespan `div` 4 = net.targetTimespan `div` 4
| s > net.targetTimespan * 4 = net.targetTimespan * 4
| otherwise = s
l = fst $ decodeCompact header.bits
new = l * fromIntegral n `div` fromIntegral net.targetTimespan
-- | Returns True if the difficulty target (bits) of the header is valid and the
-- proof of work of the header matches the advertised difficulty target. This
-- function corresponds to the function @CheckProofOfWork@ from @bitcoind@ in
-- @main.cpp@.
isValidPOW :: Network -> BlockHeader -> Bool
isValidPOW net h
| target <= 0 || over || target > net.powLimit = False
| otherwise = blockPOW (headerHash h) <= fromIntegral target
where
(target, over) = decodeCompact h.bits
-- | Returns the proof of work of a block header hash as an 'Integer' number.
blockPOW :: BlockHash -> Integer
blockPOW = bsToInteger . B.reverse . runPutS . serialize
-- | Returns the work represented by this block. Work is defined as the number
-- of tries needed to solve a block in the average case with respect to the
-- target.
headerWork :: BlockHeader -> Integer
headerWork bh = largestHash `div` (target + 1)
where
target = fst $ decodeCompact bh.bits
largestHash = 1 `shiftL` 256
-- | Number of blocks on average between difficulty cycles (2016 blocks).
diffInterval :: Network -> Word32
diffInterval net = net.targetTimespan `div` net.targetSpacing
-- | Compare two blocks to get the best.
chooseBest :: BlockNode -> BlockNode -> BlockNode
chooseBest b1 b2
| b1.work == b2.work =
if b1.height >= b2.height
then b1
else b2
| b1.work > b2.work = b1
| otherwise = b2
-- | Get list of blocks for a block locator.
blockLocatorNodes :: (BlockHeaders m) => BlockNode -> m [BlockNode]
blockLocatorNodes best =
reverse <$> go [] best 1
where
e1 = error "Could not get ancestor"
go loc bn n =
let loc' = bn : loc
n' =
if length loc' > 10
then n * 2
else 1
in if bn.height < n'
then do
a <- fromMaybe e1 <$> getAncestor 0 bn
return $ a : loc'
else do
let h = bn.height - n'
bn' <- fromMaybe e1 <$> getAncestor h bn
go loc' bn' n'
-- | Get block locator.
blockLocator :: (BlockHeaders m) => BlockNode -> m BlockLocator
blockLocator bn = map (headerHash . (.header)) <$> blockLocatorNodes bn
-- | Become rich beyond your wildest dreams.
mineBlock :: Network -> Word32 -> BlockHeader -> BlockHeader
mineBlock net seed h =
head
[ j
| i <- (+ seed) <$> [0 .. maxBound],
let j = h {nonce = i},
isValidPOW net j
]
-- | Generate and append new blocks (mining). Only practical in regtest network.
appendBlocks ::
Network ->
-- | random seed
Word32 ->
BlockHeader ->
Int ->
[BlockHeader]
appendBlocks _ _ _ 0 = []
appendBlocks net seed bh i =
bh' : appendBlocks net seed bh' (i - 1)
where
bh' =
mineBlock
net
seed
bh
{ prev = headerHash bh,
-- Just to make it different in every header
merkle = sha256 $ runPutS $ serialize seed
}
-- | Find the last common block ancestor between provided block headers.
splitPoint :: (BlockHeaders m) => BlockNode -> BlockNode -> m BlockNode
splitPoint l r = do
let h = min l.height r.height
ll <- fromMaybe e <$> getAncestor h l
lr <- fromMaybe e <$> getAncestor h r
f ll lr
where
e = error "BUG: Could not get ancestor at lowest height"
f ll lr =
if ll == lr
then return lr
else do
let h = ll.height - 1
pl <- fromMaybe e <$> getAncestor h ll
pr <- fromMaybe e <$> getAncestor h lr
f pl pr
-- | Generate the entire Genesis block for 'Network'.
genesisBlock :: Network -> Ctx -> Block
genesisBlock net ctx = Block net.genesisHeader [genesisTx ctx]
-- | Compute block subsidy at particular height.
computeSubsidy :: Network -> BlockHeight -> Word64
computeSubsidy net height =
let halvings = height `div` net.halvingInterval
ini = 50 * 100 * 1000 * 1000
in if halvings >= 64
then 0
else ini `shiftR` fromIntegral halvings