{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
module Network.Haskoin.Block.Headers
( BlockNode(..)
, BlockHeaders(..)
, BlockWork
, genesisNode
, genesisBlock
, isGenesis
, chooseBest
, parentBlock
, getParents
, getAncestor
, splitPoint
, connectBlocks
, connectBlock
, blockLocator
, HeaderMemory(..)
, ShortBlockHash
, BlockMap
, shortBlockHash
, initialChain
, genesisMap
, appendBlocks
, validBlock
, validCP
, afterLastCP
, bip34
, validVersion
, lastNoMinDiff
, nextWorkRequired
, nextEdaWorkRequired
, nextDaaWorkRequired
, computeTarget
, getSuitableBlock
, nextPowWorkRequired
, calcNextWork
, isValidPOW
, blockPOW
, headerWork
, diffInterval
, blockLocatorNodes
, mineBlock
, ) where
import Control.Applicative ((<|>))
import Control.Monad (guard, 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.Bits (shiftL, shiftR, (.&.))
import qualified Data.ByteString as B
import Data.ByteString.Short (ShortByteString, fromShort,
toShort)
import Data.Function (on)
import Data.Hashable
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.List (sort, sortBy)
import Data.Maybe (fromMaybe, listToMaybe)
import Data.Serialize as S (Serialize (..),
decode, encode, get,
put)
import Data.Serialize.Get as S
import Data.Serialize.Put as S
import Data.Typeable (Typeable)
import Data.Word (Word32, Word64)
import GHC.Generics
import Network.Haskoin.Block.Common
import Network.Haskoin.Constants
import Network.Haskoin.Crypto
import Network.Haskoin.Transaction.Common
import Network.Haskoin.Util
type ShortBlockHash = Word64
type BlockMap = HashMap ShortBlockHash ShortByteString
type BlockWork = Integer
data BlockNode
= BlockNode { nodeHeader :: !BlockHeader
, nodeHeight :: !BlockHeight
, nodeWork :: !BlockWork
, nodeSkip :: !BlockHash }
| GenesisNode { nodeHeader :: !BlockHeader
, nodeHeight :: !BlockHeight
, nodeWork :: !BlockWork }
deriving (Show, Read, Generic, Hashable)
instance Serialize BlockNode where
get = do
nodeHeader <- S.get
nodeHeight <- getWord32le
nodeWork <- S.get
if nodeHeight == 0
then return GenesisNode {..}
else do
nodeSkip <- S.get
return BlockNode {..}
put bn = do
put $ nodeHeader bn
putWord32le $ nodeHeight bn
put $ nodeWork bn
case bn of
GenesisNode {} -> return ()
BlockNode {} -> put $ nodeSkip bn
instance Eq BlockNode where
(==) = (==) `on` nodeHeader
instance Ord BlockNode where
compare = compare `on` nodeHeight
data HeaderMemory = HeaderMemory
{ memoryHeaderMap :: !BlockMap
, memoryBestHeader :: !BlockNode
} deriving (Eq, Typeable, Show, Read, Generic, Hashable)
class Monad m => BlockHeaders m where
addBlockHeader :: BlockNode -> m ()
getBlockHeader :: BlockHash -> m (Maybe BlockNode)
getBestBlockHeader :: m BlockNode
setBestBlockHeader :: BlockNode -> m ()
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 memoryBestHeader
setBestBlockHeader bn = modify $ \s -> s { memoryBestHeader = bn }
initialChain :: Network -> HeaderMemory
initialChain net = HeaderMemory
{ memoryHeaderMap = genesisMap net
, memoryBestHeader = genesisNode net
}
genesisMap :: Network -> BlockMap
genesisMap net =
HashMap.singleton
(shortBlockHash (headerHash (getGenesisHeader net)))
(toShort (encode (genesisNode net)))
addBlockHeaderMemory :: BlockNode -> HeaderMemory -> HeaderMemory
addBlockHeaderMemory bn s@HeaderMemory{..} =
let bm' = addBlockToMap bn memoryHeaderMap
in s { memoryHeaderMap = bm' }
getBlockHeaderMemory :: BlockHash -> HeaderMemory -> Maybe BlockNode
getBlockHeaderMemory bh HeaderMemory {..} = do
bs <- shortBlockHash bh `HashMap.lookup` memoryHeaderMap
eitherToMaybe . decode $ fromShort bs
shortBlockHash :: BlockHash -> ShortBlockHash
shortBlockHash = either error id . decode . B.take 8 . encode
addBlockToMap :: BlockNode -> BlockMap -> BlockMap
addBlockToMap node =
HashMap.insert
(shortBlockHash $ headerHash $ nodeHeader node)
(toShort $ encode node)
getAncestor :: BlockHeaders m
=> BlockHeight
-> BlockNode
-> m (Maybe BlockNode)
getAncestor height node
| height > nodeHeight node = return Nothing
| otherwise = go node
where
e1 = error "Could not get skip header"
e2 = error "Could not get previous block header"
go walk
| nodeHeight walk > height =
let heightSkip = skipHeight (nodeHeight walk)
heightSkipPrev = skipHeight (nodeHeight walk - 1)
in if not (isGenesis walk) &&
(heightSkip == height ||
(heightSkip > height &&
not
(heightSkipPrev < heightSkip - 2 &&
heightSkipPrev >= height)))
then do
walk' <- fromMaybe e1 <$> getBlockHeader (nodeSkip walk)
go walk'
else do
walk' <-
fromMaybe e2 <$>
getBlockHeader (prevBlock (nodeHeader walk))
go walk'
| otherwise = return $ Just walk
isGenesis :: BlockNode -> Bool
isGenesis GenesisNode{} = True
isGenesis BlockNode{} = False
genesisNode :: Network -> BlockNode
genesisNode net =
GenesisNode
{ nodeHeader = getGenesisHeader net
, nodeHeight = 0
, nodeWork = headerWork (getGenesisHeader net)
}
connectBlocks :: BlockHeaders m
=> Network
-> 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 == prevBlock h2 && chained (h2 : hs)
chained _ = True
skipit lbh ls par
| sh == nodeHeight lbh = return lbh
| sh < nodeHeight lbh = do
skM <- lift $ getAncestor sh lbh
case skM of
Just sk -> return sk
Nothing ->
throwError $
"BUG: Could not get skip for block " ++
show (headerHash $ nodeHeader par)
| otherwise = do
let sn = ls !! fromIntegral (nodeHeight par - sh)
when (nodeHeight sn /= sh) $
throwError "BUG: Node height not right in skip"
return sn
where
sh = skipHeight (nodeHeight par + 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
parentBlock :: BlockHeaders m
=> BlockHeader
-> m (Maybe BlockNode)
parentBlock bh = getBlockHeader (prevBlock bh)
connectBlock ::
BlockHeaders m
=> Network
-> 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 (nodeHeight par + 1)) par
sk <-
case skM of
Just sk -> return sk
Nothing ->
throwError $
"BUG: Could not get skip for block " ++
show (headerHash $ nodeHeader par)
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
validBlock :: Network
-> Timestamp
-> BlockNode
-> BlockNode
-> [BlockNode]
-> BlockHeader
-> BlockNode
-> Either String BlockNode
validBlock net t bb par pars bh sk = do
let mt = medianTime . map (blockTimestamp . nodeHeader) $ par : pars
nt = blockTimestamp bh
hh = headerHash bh
nv = blockVersion bh
ng = nodeHeight par + 1
aw = nodeWork par + 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 (nodeHeight bb) 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 { nodeHeader = bh
, nodeHeight = ng
, nodeWork = aw
, nodeSkip = headerHash $ nodeHeader sk
}
medianTime :: [Timestamp] -> Timestamp
medianTime ts
| null ts = error "Cannot compute median time of empty header list"
| otherwise = sort ts !! (length ts `div` 2)
skipHeight :: BlockHeight -> BlockHeight
skipHeight height
| height < 2 = 0
| height .&. 1 /= 0 = invertLowestOne (invertLowestOne $ height - 1) + 1
| otherwise = invertLowestOne height
invertLowestOne :: BlockHeight -> BlockHeight
invertLowestOne height = height .&. (height - 1)
getParents :: BlockHeaders m
=> Int
-> BlockNode
-> m [BlockNode]
getParents = getpars []
where
getpars acc 0 _ = return $ reverse acc
getpars acc _ GenesisNode{} = return $ reverse acc
getpars acc n BlockNode{..} = do
parM <- getBlockHeader $ prevBlock nodeHeader
case parM of
Just bn -> getpars (bn : acc) (n - 1) bn
Nothing -> error "BUG: All non-genesis blocks should have a parent"
validCP :: Network
-> BlockHeight
-> BlockHash
-> Bool
validCP net height newChildHash =
case lookup height (getCheckpoints net) of
Just cpHash -> cpHash == newChildHash
Nothing -> True
afterLastCP :: Network
-> BlockHeight
-> BlockHeight
-> Bool
afterLastCP net bestHeight newChildHeight =
case lM of
Just l -> l < newChildHeight
Nothing -> True
where
lM =
listToMaybe . reverse $
[c | (c, _) <- getCheckpoints net, c <= bestHeight]
bip34 :: Network
-> BlockHeight
-> BlockHash
-> Bool
bip34 net height hsh
| fst (getBip34Block net) == 0 = True
| fst (getBip34Block net) == height = snd (getBip34Block net) == hsh
| otherwise = True
validVersion :: Network
-> BlockHeight
-> Word32
-> Bool
validVersion net height version
| version < 2 = height < fst (getBip34Block net)
| version < 3 = height < getBip66Height net
| version < 4 = height < getBip65Height net
| otherwise = True
lastNoMinDiff :: BlockHeaders m => Network -> BlockNode -> m BlockNode
lastNoMinDiff net bn@BlockNode {..} = do
let i = nodeHeight `mod` diffInterval net /= 0
c = encodeCompact (getPowLimit net)
l = blockBits nodeHeader == c
e1 =
error $
"Could not get block header for parent of " ++
show (headerHash nodeHeader)
if i && l
then do
bn' <- fromMaybe e1 <$> getBlockHeader (prevBlock nodeHeader)
lastNoMinDiff net bn'
else return bn
lastNoMinDiff _ bn@GenesisNode{} = return bn
nextWorkRequired :: BlockHeaders m
=> Network
-> BlockNode
-> BlockHeader
-> m Word32
nextWorkRequired net par bh = do
let mf = daa <|> eda <|> pow
case mf of
Just f -> f net par bh
Nothing ->
error
"Could not get an appropriate difficulty calculation algorithm"
where
daa = getDaaBlockHeight net >>= \daaHeight -> do
guard (nodeHeight par + 1 >= daaHeight)
return nextDaaWorkRequired
eda = getEdaBlockHeight net >>= \edaHeight -> do
guard (nodeHeight par + 1 >= edaHeight)
return nextEdaWorkRequired
pow = return nextPowWorkRequired
nextEdaWorkRequired ::
BlockHeaders m => Network -> BlockNode -> BlockHeader -> m Word32
nextEdaWorkRequired net par bh
| nodeHeight par + 1 `mod` diffInterval net == 0 =
nextWorkRequired net par bh
| minDifficulty = return (encodeCompact (getPowLimit net))
| blockBits (nodeHeader par) == encodeCompact (getPowLimit net) =
return (encodeCompact (getPowLimit net))
| otherwise = do
par6 <- fromMaybe e1 <$> getAncestor (nodeHeight par - 6) par
pars <- getParents 10 par
pars6 <- getParents 10 par6
let par6med =
medianTime $ map (blockTimestamp . nodeHeader) (par6 : pars6)
parmed = medianTime $ map (blockTimestamp . nodeHeader) (par : pars)
mtp6 = parmed - par6med
if mtp6 < 12 * 3600
then return $ blockBits (nodeHeader par)
else return $
let (diff, _) = decodeCompact (blockBits (nodeHeader par))
ndiff = diff + (diff `shiftR` 2)
in if getPowLimit net > ndiff
then encodeCompact (getPowLimit net)
else encodeCompact ndiff
where
minDifficulty =
blockTimestamp bh >
blockTimestamp (nodeHeader par) + getTargetSpacing net * 2
e1 = error "Could not get seventh ancestor of block"
nextDaaWorkRequired ::
BlockHeaders m => Network -> BlockNode -> BlockHeader -> m Word32
nextDaaWorkRequired net par bh
| minDifficulty = return (encodeCompact (getPowLimit net))
| otherwise = do
let height = nodeHeight par
unless (height >= diffInterval net) $
error "Block height below difficulty interval"
l <- getSuitableBlock par
par144 <- fromMaybe e1 <$> getAncestor (height - 144) par
f <- getSuitableBlock par144
let nextTarget = computeTarget net f l
if nextTarget > getPowLimit net
then return $ encodeCompact (getPowLimit net)
else return $ encodeCompact nextTarget
where
e1 = error "Cannot get ancestor at parent - 144 height"
minDifficulty =
blockTimestamp bh >
blockTimestamp (nodeHeader par) + getTargetSpacing net * 2
computeTarget :: Network -> BlockNode -> BlockNode -> Integer
computeTarget net f l =
let work = (nodeWork l - nodeWork f) * fromIntegral (getTargetSpacing net)
actualTimespan =
blockTimestamp (nodeHeader l) - blockTimestamp (nodeHeader f)
actualTimespan'
| actualTimespan > 288 * getTargetSpacing net =
288 * getTargetSpacing net
| actualTimespan < 72 * getTargetSpacing net =
72 * getTargetSpacing net
| otherwise = actualTimespan
work' = work `div` fromIntegral actualTimespan'
in 2 ^ (256 :: Integer) `div` work'
getSuitableBlock :: BlockHeaders m => BlockNode -> m BlockNode
getSuitableBlock par = do
unless (nodeHeight par >= 3) $ error "Block height is less than three"
blocks <- (par :) <$> getParents 2 par
return $ sortBy (compare `on` blockTimestamp . nodeHeader) blocks !! 1
nextPowWorkRequired ::
BlockHeaders m => Network -> BlockNode -> BlockHeader -> m Word32
nextPowWorkRequired net par bh
| nodeHeight par + 1 `mod` diffInterval net /= 0 =
if getAllowMinDifficultyBlocks net
then if ht > pt + delta
then return $ encodeCompact (getPowLimit net)
else do
d <- lastNoMinDiff net par
return $ blockBits $ nodeHeader d
else return $ blockBits $ nodeHeader par
| otherwise = do
let rh = nodeHeight par - (diffInterval net - 1)
a <- fromMaybe e1 <$> getAncestor rh par
let t = blockTimestamp $ nodeHeader a
return $ calcNextWork net (nodeHeader par) t
where
e1 = error "Could not get ancestor for block header"
pt = blockTimestamp $ nodeHeader par
ht = blockTimestamp bh
delta = getTargetSpacing net * 2
calcNextWork :: Network
-> BlockHeader
-> Timestamp
-> Word32
calcNextWork net header time
| getPowNoRetargetting net = blockBits header
| new > getPowLimit net = encodeCompact (getPowLimit net)
| otherwise = encodeCompact new
where
s = blockTimestamp header - time
n | s < getTargetTimespan net `div` 4 = getTargetTimespan net `div` 4
| s > getTargetTimespan net * 4 = getTargetTimespan net * 4
| otherwise = s
l = fst $ decodeCompact $ blockBits header
new = l * fromIntegral n `div` fromIntegral (getTargetTimespan net)
isValidPOW :: Network -> BlockHeader -> Bool
isValidPOW net h
| target <= 0 || over || target > getPowLimit net = False
| otherwise = blockPOW (headerHash h) <= fromIntegral target
where
(target, over) = decodeCompact $ blockBits h
blockPOW :: BlockHash -> Integer
blockPOW = bsToInteger . B.reverse . encode
headerWork :: BlockHeader -> Integer
headerWork bh = largestHash `div` (target + 1)
where
target = fst $ decodeCompact $ blockBits bh
largestHash = 1 `shiftL` 256
diffInterval :: Network -> Word32
diffInterval net = getTargetTimespan net `div` getTargetSpacing net
chooseBest :: BlockNode -> BlockNode -> BlockNode
chooseBest b1 b2 | nodeWork b1 == nodeWork b2 =
if nodeHeight b1 >= nodeHeight b2
then b1
else b2
| nodeWork b1 > nodeWork b2 = b1
| otherwise = b2
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 nodeHeight bn < n'
then do a <- fromMaybe e1 <$> getAncestor 0 bn
return $ a : loc'
else do let h = nodeHeight bn - n'
bn' <- fromMaybe e1 <$> getAncestor h bn
go loc' bn' n'
blockLocator :: BlockHeaders m => BlockNode -> m BlockLocator
blockLocator bn = map (headerHash . nodeHeader) <$> blockLocatorNodes bn
mineBlock :: Network -> Word32 -> BlockHeader -> BlockHeader
mineBlock net seed h =
head
[ j
| i <- (+ seed) <$> [0 .. maxBound]
, let j = h {bhNonce = i}
, isValidPOW net j
]
appendBlocks ::
Network
-> Word32
-> BlockHeader
-> Int
-> [BlockHeader]
appendBlocks _ _ _ 0 = []
appendBlocks net seed bh i =
bh' : appendBlocks net seed bh' (i - 1)
where
bh' = mineBlock net seed bh
{ prevBlock = headerHash bh
, merkleRoot = sha256 $ encode seed
}
splitPoint :: BlockHeaders m => BlockNode -> BlockNode -> m BlockNode
splitPoint l r = do
let h = min (nodeHeight l) (nodeHeight r)
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 = nodeHeight ll - 1
pl <- fromMaybe e <$> getAncestor h ll
pr <- fromMaybe e <$> getAncestor h lr
f pl pr
genesisBlock :: Network -> Block
genesisBlock net = Block (getGenesisHeader net) [genesisTx]