module Network.Haskoin.Node.HeaderTree
( BlockChainAction(..)
, BlockHeight
, NodeBlock
, Timestamp
, initHeaderTree
, migrateHeaderTree
, getBestBlock
, getHeads
, getBlockByHash
, getParentBlock
, getBlockWindow
, getBlockAfterTime
, getChildBlocks
, getBlockByHeight
, getBlocksByHeight
, getBlocksFromHeight
, getBlocksAtHeight
, putBlock
, putBlocks
, genesisBlock
, splitBlock
, splitChains
, nodeBlock
, nodeBlockHeight
, nodeHash
, nodeHeader
, nodePrev
, nodeTimestamp
, nodeWork
, nodeHeight
, nodeChain
, isBestChain
, isChainReorg
, isSideChain
, isKnownChain
, connectHeader
, connectHeaders
, blockLocator
, pruneChain
) where
import Control.Monad (foldM, forM, unless,
when, (<=<))
import Control.Monad.State (evalStateT, get, put)
import Control.Monad.Trans (MonadIO, lift)
import Control.Monad.Trans.Either (EitherT, left,
runEitherT)
import Data.Bits (shiftL)
import qualified Data.ByteString as BS (reverse, take)
import Data.Function (on)
import Data.List (find, maximumBy, sort)
import Data.Maybe (fromMaybe, isNothing,
listToMaybe, mapMaybe)
import Data.Serialize (decode, encode)
import Data.String.Conversions (cs)
import Data.Word (Word32)
import Database.Esqueleto (Esqueleto, Value, asc,
delete, from, groupBy,
in_, insertMany_, limit,
max_, not_, orderBy,
select, set, unValue,
update, val, valList,
where_, (!=.), (&&.),
(<=.), (=.), (==.),
(>.), (>=.), (^.),
(||.))
import Database.Persist (Entity (..), insert_)
import Database.Persist.Sql (SqlPersistT)
import Network.Haskoin.Block
import Network.Haskoin.Constants
import Network.Haskoin.Crypto
import Network.Haskoin.Node.Checkpoints
import Network.Haskoin.Node.HeaderTree.Model
import Network.Haskoin.Node.HeaderTree.Types
import Network.Haskoin.Util
data BlockChainAction
= BestChain { actionNodes :: ![NodeBlock] }
| ChainReorg { actionSplitNode :: !NodeBlock
, actionOldNodes :: ![NodeBlock]
, actionNodes :: ![NodeBlock]
}
| SideChain { actionNodes :: ![NodeBlock] }
| KnownChain { actionNodes :: ![NodeBlock] }
deriving (Show, Eq)
type MinWork = Word32
shortHash :: BlockHash -> ShortHash
shortHash = fromRight . decode . BS.take 8 . getHash256 . getBlockHash
nodeHeader :: NodeBlock -> BlockHeader
nodeHeader = getNodeHeader . nodeBlockHeader
nodeHash :: NodeBlock -> BlockHash
nodeHash = headerHash . nodeHeader
nodePrev :: NodeBlock -> BlockHash
nodePrev = prevBlock . nodeHeader
nodeTimestamp :: NodeBlock -> Timestamp
nodeTimestamp = blockTimestamp . nodeHeader
nodeWork :: NodeBlock -> Work
nodeWork = nodeBlockWork
nodeHeight :: NodeBlock -> BlockHeight
nodeHeight = nodeBlockHeight
nodeChain :: NodeBlock -> Word32
nodeChain = nodeBlockChain
diffInterval :: Word32
diffInterval = targetTimespan `div` targetSpacing
genesisBlock :: NodeBlock
genesisBlock = NodeBlock
{ nodeBlockHash = shortHash $ headerHash genesisHeader
, nodeBlockHeader = NodeHeader genesisHeader
, nodeBlockWork = 1.0
, nodeBlockHeight = 0
, nodeBlockChain = 0
}
initHeaderTree :: MonadIO m => SqlPersistT m ()
initHeaderTree = do
nodeM <- getBlockByHash $ headerHash genesisHeader
when (isNothing nodeM) $ putBlock genesisBlock
getVerifyParams
:: MonadIO m
=> BlockHeader
-> EitherT String (SqlPersistT m)
(NodeBlock, [Timestamp], Timestamp, Word32, Maybe Word32)
getVerifyParams bh = do
parentM <- lift $ getBlockByHash $ prevBlock bh
parent <- maybe (left "Could not get parent node") return parentM
checkPointM <- fmap nodeBlockHeight <$> lift lastSeenCheckpoint
diffBlockM <- lift $ getBlockByHeight parent $
nodeBlockHeight parent `div` diffInterval * diffInterval
diffTime <- maybe (left "Could not get difficulty change block")
(return . nodeTimestamp)
diffBlockM
medianBlocks <- lift $ map nodeTimestamp <$>
getBlocksFromHeight parent 11 (min 0 $ nodeBlockHeight parent 10)
minWork <- lift $ findMinWork parent
return (parent, medianBlocks, diffTime, minWork, checkPointM)
findMinWork :: MonadIO m => NodeBlock -> SqlPersistT m MinWork
findMinWork bn
| isMinWork bn = return $ blockBits $ nodeHeader bn
| otherwise = getParentBlock bn >>=
maybe (return $ blockBits $ nodeHeader bn) findMinWork
isMinWork :: NodeBlock -> Bool
isMinWork bn
| not allowMinDifficultyBlocks = True
| nodeBlockHeight bn `mod` diffInterval == 0 = True
| blockBits (nodeHeader bn) /= encodeCompact powLimit = True
| otherwise = False
splitKnown :: MonadIO m
=> [BlockHeader]
-> SqlPersistT m ([NodeBlock], [BlockHeader])
splitKnown hs = do
(kno, unk) <- foldM f ([], []) hs
return (reverse kno, reverse unk)
where
f (kno, []) n = do
bnM <- getBlockByHash (headerHash n)
case bnM of
Nothing -> return (kno, [n])
Just bn -> return (bn:kno, [])
f (kno, unk) n = return (kno, n:unk)
connectHeader :: MonadIO m
=> NodeBlock
-> BlockHeader
-> Timestamp
-> SqlPersistT m (Either String BlockChainAction)
connectHeader best bh ts = runEitherT $ do
(kno, _) <- lift $ splitKnown [bh]
case kno of
[] -> do
(parent, medians, diffTime, minWork, cpM) <- getVerifyParams bh
chain <- lift $ getChain parent
let bn = nodeBlock parent chain bh
liftEither $
verifyBlockHeader parent medians diffTime cpM minWork ts bh
lift $ putBlock bn
lift $ evalNewChain best [bn]
_ -> return $ KnownChain kno
connectHeaders :: MonadIO m
=> NodeBlock
-> [BlockHeader]
-> Timestamp
-> SqlPersistT m (Either String BlockChainAction)
connectHeaders _ [] _ = runEitherT $ left "Nothing to connect"
connectHeaders best bhs ts = runEitherT $ do
unless (validChain bhs) $ left "Block headers do not form a valid chain"
(kno, unk) <- lift $ splitKnown bhs
case unk of
[] -> return $ KnownChain kno
(bh:_) -> do
(parent, medians, diffTime, minWork, cpM) <- getVerifyParams bh
chain <- lift $ getChain parent
nodes <- (`evalStateT` (parent, diffTime, medians, minWork)) $
forM unk $ \b -> do
(p, d, ms, mw) <- get
lift $ liftEither $ verifyBlockHeader p ms d cpM mw ts b
let bn = nodeBlock p chain b
d' = if nodeBlockHeight bn `mod` diffInterval == 0
then blockTimestamp b
else d
ms' = blockTimestamp b : if length ms == 11
then tail ms
else ms
mw' = if isMinWork bn then blockBits b else mw
put (bn, d', ms', mw')
return bn
lift $ putBlocks nodes
lift $ evalNewChain best nodes
where
validChain (a:b:xs) = prevBlock b == headerHash a && validChain (b:xs)
validChain [_] = True
validChain _ = False
isBestChain :: BlockChainAction -> Bool
isBestChain (BestChain _) = True
isBestChain _ = False
isChainReorg :: BlockChainAction -> Bool
isChainReorg ChainReorg{} = True
isChainReorg _ = False
isSideChain :: BlockChainAction -> Bool
isSideChain (SideChain _) = True
isSideChain _ = False
isKnownChain :: BlockChainAction -> Bool
isKnownChain (KnownChain _) = True
isKnownChain _ = False
blockLocator :: MonadIO m => NodeBlock -> SqlPersistT m BlockLocator
blockLocator node = do
nodes <- getBlocksByHeight node bs
return $ map nodeHash nodes
where
h = nodeBlockHeight node
f x s = (fst x s, fst x > s)
bs = (++ [0]) $ map fst $ takeWhile snd $
[(h x, x < h) | x <- [0..9]] ++
scanl f (h 10, h > 10) [2 ^ (x :: Word32) | x <- [1..]]
verifyBlockHeader :: NodeBlock
-> [Timestamp]
-> Timestamp
-> Maybe Word32
-> MinWork
-> Timestamp
-> BlockHeader
-> Either String ()
verifyBlockHeader par mts dt cp mw ts bh = do
unless (isValidPOW bh) $
Left "Invalid proof of work"
unless (blockTimestamp bh <= ts + 2 * 60 * 60) $
Left "Invalid header timestamp"
let nextWork = nextWorkRequired par dt mw bh
unless (blockBits bh == nextWork) $
Left "Incorrect work transition (bits)"
let sortedMedians = sort mts
medianTime = sortedMedians !! (length sortedMedians `div` 2)
when (blockTimestamp bh <= medianTime) $
Left "Block timestamp is too early"
let newHeight = nodeBlockHeight par + 1
unless (maybe True (fromIntegral newHeight >) cp) $
Left "Rewriting pre-checkpoint chain"
unless (verifyCheckpoint (fromIntegral newHeight) (headerHash bh)) $
Left "Rejected by checkpoint lock-in"
when (networkName == "prodnet"
&& blockVersion bh == 1
&& nodeBlockHeight par + 1 >= 227836) $
Left "Rejected version 1 block"
nodeBlock :: NodeBlock
-> Word32
-> BlockHeader
-> NodeBlock
nodeBlock parent chain bh = NodeBlock
{ nodeBlockHash = shortHash $ headerHash bh
, nodeBlockHeader = NodeHeader bh
, nodeBlockWork = newWork
, nodeBlockHeight = height
, nodeBlockChain = chain
}
where
newWork = nodeBlockWork parent + fromIntegral
(headerWork bh `div` headerWork genesisHeader)
height = nodeBlockHeight parent + 1
getBlockWindow :: MonadIO m
=> NodeBlock
-> NodeBlock
-> Word32
-> SqlPersistT m BlockChainAction
getBlockWindow best node cnt = do
(_, old, new) <- splitChains (node, 0) (best, cnt)
return $ if null old then BestChain new else ChainReorg node old new
splitChains :: MonadIO m
=> (NodeBlock, Word32)
-> (NodeBlock, Word32)
-> SqlPersistT m (NodeBlock, [NodeBlock], [NodeBlock])
splitChains (l, ln) (r, rn) = do
sn <- splitBlock l r
(split:ls) <- getBlocksFromHeight l ln (nodeBlockHeight sn)
rs <- getBlocksFromHeight r rn (nodeBlockHeight sn + 1)
return (split, ls, rs)
getParentBlock :: MonadIO m
=> NodeBlock
-> SqlPersistT m (Maybe NodeBlock)
getParentBlock node
| nodeBlockHeight node == 0 = return Nothing
| otherwise = getBlockByHash p
where
p = nodePrev node
getChildBlocks :: MonadIO m
=> BlockHash
-> SqlPersistT m [NodeBlock]
getChildBlocks h = do
ch <- (+1) . nodeBlockHeight . fromMaybe e <$> getBlockByHash h
filter ((==h) . nodePrev) <$> getBlocksAtHeight ch
where
e = error $ "Cannot find block hash " ++ cs (blockHashToHex h)
lastSeenCheckpoint :: MonadIO m
=> SqlPersistT m (Maybe NodeBlock)
lastSeenCheckpoint =
fmap listToMaybe $ getBlocksByHash $ map snd $ reverse checkpointList
nextWorkRequired :: NodeBlock
-> Timestamp
-> MinWork
-> BlockHeader
-> Word32
nextWorkRequired par ts mw bh
| nodeBlockHeight par == 0 = encodeCompact powLimit
| (nodeBlockHeight par + 1) `mod` diffInterval /= 0 =
if allowMinDifficultyBlocks
then minPOW
else blockBits $ nodeHeader par
| otherwise = workFromInterval ts (nodeHeader par)
where
delta = targetSpacing * 2
minPOW
| blockTimestamp bh > nodeTimestamp par + delta = encodeCompact powLimit
| otherwise = mw
workFromInterval :: Timestamp -> BlockHeader -> Word32
workFromInterval ts lastB
| newDiff > powLimit = encodeCompact powLimit
| otherwise = encodeCompact newDiff
where
t = fromIntegral $ blockTimestamp lastB ts
actualTime
| t < targetTimespan `div` 4 = targetTimespan `div` 4
| t > targetTimespan * 4 = targetTimespan * 4
| otherwise = t
lastDiff = decodeCompact $ blockBits lastB
newDiff = lastDiff * toInteger actualTime `div` toInteger targetTimespan
isValidPOW :: BlockHeader -> Bool
isValidPOW bh
| target <= 0 || target > powLimit = False
| otherwise = headerPOW bh <= fromIntegral target
where
target = decodeCompact $ blockBits bh
headerPOW :: BlockHeader -> Integer
headerPOW = bsToInteger . BS.reverse . encode . headerHash
headerWork :: BlockHeader -> Integer
headerWork bh =
fromIntegral $ largestHash `div` (target + 1)
where
target = decodeCompact (blockBits bh)
largestHash = 1 `shiftL` 256
chainPathQuery :: forall (expr :: * -> *) (query :: * -> *) backend.
Esqueleto query expr backend
=> expr (Entity NodeBlock)
-> [NodeBlock]
-> expr (Value Bool)
chainPathQuery _ [] = error "Monsters, monsters everywhere"
chainPathQuery t [NodeBlock{..}] =
t ^. NodeBlockHeight <=. val nodeBlockHeight &&.
t ^. NodeBlockChain ==. val nodeBlockChain
chainPathQuery t (n1:bs@(n2:_)) = chainPathQuery t bs ||.
( t ^. NodeBlockHeight <=. val (nodeBlockHeight n1)
&&. t ^. NodeBlockHeight >. val (nodeBlockHeight n2)
&&. t ^. NodeBlockChain ==. val (nodeBlockChain n1)
)
getHeads :: MonadIO m => SqlPersistT m [NodeBlock]
getHeads = fmap (map (entityVal . snd)) $ select $ from $ \t -> do
groupBy $ t ^. NodeBlockChain
return (max_ (t ^. NodeBlockHeight), t)
getChain :: MonadIO m
=> NodeBlock
-> SqlPersistT m Word32
getChain parent = do
maxHeightM <- fmap (unValue <=< listToMaybe) $ select $ from $ \t -> do
where_ $ t ^. NodeBlockChain ==. val (nodeBlockChain parent)
return $ max_ $ t ^. NodeBlockHeight
let maxHeight = fromMaybe (error "That chain does not exist") maxHeightM
if maxHeight == nodeBlockHeight parent
then return $ nodeBlockChain parent
else do
maxChainM <- fmap (unValue <=< listToMaybe) $ select $ from $ \t ->
return $ max_ $ t ^. NodeBlockChain
let maxChain = fromMaybe (error "Ran out of chains") maxChainM
return $ maxChain + 1
getPivots :: MonadIO m => NodeBlock -> SqlPersistT m [NodeBlock]
getPivots = go []
where
go acc b
| nodeBlockChain b == 0 = return $ genesisBlock : b : acc
| otherwise = do
l <- fromMaybe (error "Houston, we have a problem") <$>
getChainLowest b
c <- fromMaybe (error "Ground Control to Major Tom") <$>
getParentBlock l
go (b:acc) c
getChainLowest :: MonadIO m => NodeBlock -> SqlPersistT m (Maybe NodeBlock)
getChainLowest nb = fmap (listToMaybe . map entityVal) $
select $ from $ \t -> do
where_ $ t ^. NodeBlockChain ==. val (nodeBlockChain nb)
orderBy [ asc $ t ^. NodeBlockHeight ]
limit 1
return t
splitBlock :: MonadIO m
=> NodeBlock
-> NodeBlock
-> SqlPersistT m NodeBlock
splitBlock l r = if nodeBlockChain l == nodeBlockChain r
then if nodeBlockHeight l < nodeBlockHeight r
then return l
else return r
else do
pivotsL <- getPivots l
pivotsR <- getPivots r
let ns = zip pivotsL pivotsR
f (x,y) = nodeBlockChain x == nodeBlockChain y
(one, two) = last $ takeWhile f ns
if nodeBlockHeight one < nodeBlockHeight two
then return one
else return two
putBlock :: MonadIO m => NodeBlock -> SqlPersistT m ()
putBlock = insert_
putBlocks :: MonadIO m => [NodeBlock] -> SqlPersistT m ()
putBlocks = mapM_ insertMany_ . f
where
f [] = []
f xs = let (xs',xxs) = splitAt 50 xs in xs' : f xxs
getBestBlock :: MonadIO m => SqlPersistT m NodeBlock
getBestBlock =
maximumBy (compare `on` nodeBlockWork) <$> getHeads
getBlockByHash :: MonadIO m => BlockHash -> SqlPersistT m (Maybe NodeBlock)
getBlockByHash h =
fmap (listToMaybe . map entityVal) $ select $ from $ \t -> do
where_ $ t ^. NodeBlockHash ==. val (shortHash h)
return t
getBlocksByHash :: MonadIO m
=> [BlockHash]
-> SqlPersistT m [NodeBlock]
getBlocksByHash hashes = do
nodes <- fmap (map entityVal) $ select $ from $ \t -> do
where_ $ t ^. NodeBlockHash `in_` valList (map shortHash hashes)
return t
return $ mapMaybe
(\h -> find ((== shortHash h) . nodeBlockHash) nodes)
hashes
getBlockByHeight :: MonadIO m
=> NodeBlock
-> BlockHeight
-> SqlPersistT m (Maybe NodeBlock)
getBlockByHeight block height = do
forks <- reverse <$> getPivots block
fmap (listToMaybe . map entityVal) $ select $ from $ \t -> do
where_ $ chainPathQuery t forks &&.
t ^. NodeBlockHeight ==. val height
return t
getBlocksByHeight :: MonadIO m
=> NodeBlock
-> [BlockHeight]
-> SqlPersistT m [NodeBlock]
getBlocksByHeight best heights = do
forks <- reverse <$> getPivots best
nodes <- fmap (map entityVal) $ select $ from $ \t -> do
where_ $ chainPathQuery t forks &&.
t ^. NodeBlockHeight `in_` valList heights
return t
return $ mapMaybe (\h -> find ((==h) . nodeBlockHeight) nodes) heights
getBlocksFromHeight :: MonadIO m
=> NodeBlock
-> Word32
-> BlockHeight
-> SqlPersistT m [NodeBlock]
getBlocksFromHeight block cnt height = do
forks <- reverse <$> getPivots block
fmap (map entityVal) $ select $ from $ \t -> do
where_ $ chainPathQuery t forks &&.
t ^. NodeBlockHeight >=. val height
when (cnt > 0) $ limit $ fromIntegral cnt
return t
getBlockAfterTime :: MonadIO m => Timestamp -> SqlPersistT m (Maybe NodeBlock)
getBlockAfterTime ts = do
n@NodeBlock{..} <- getBestBlock
f genesisBlock n
where
f l r | nodeTimestamp r < ts =
return Nothing
| nodeTimestamp l >= ts =
return $ Just l
| (nodeBlockHeight r nodeBlockHeight l) `div` 2 == 0 =
return $ Just r
| otherwise = do
let rh = nodeBlockHeight r
lh = nodeBlockHeight l
mh = rh (rh lh) `div` 2
m <- fromMaybe (error "My God, it’s full of stars!") <$>
getBlockByHeight r mh
if nodeTimestamp m > ts then f l m else f m r
getBlocksAtHeight :: MonadIO m => BlockHeight -> SqlPersistT m [NodeBlock]
getBlocksAtHeight height = fmap (map entityVal) $ select $ from $ \t -> do
where_ $ t ^. NodeBlockHeight ==. val height
return t
evalNewChain :: MonadIO m
=> NodeBlock
-> [NodeBlock]
-> SqlPersistT m BlockChainAction
evalNewChain _ [] = error "You find yourself in the dungeon of missing blocks"
evalNewChain best newNodes
| buildsOnBest = do
return $ BestChain newNodes
| nodeBlockWork (last newNodes) > nodeBlockWork best = do
(split, old, new) <- splitChains (best, 0) (head newNodes, 0)
return $ ChainReorg split old (new ++ tail newNodes)
| otherwise = do
(split, _, new) <- splitChains (best, 0) (head newNodes, 0)
case new of
[] -> return $ KnownChain newNodes
_ -> return $ SideChain $ split : new ++ tail newNodes
where
buildsOnBest = nodePrev (head newNodes) == nodeHash best
pruneChain :: MonadIO m
=> NodeBlock
-> SqlPersistT m NodeBlock
pruneChain best = if (nodeBlockChain best == 0) then return best else do
forks <- reverse <$> getPivots best
delete $ from $ \t -> where_ $ not_ (chainPathQuery t forks)
update $ \t -> do
set t [ NodeBlockChain =. val 0 ]
where_ $ t ^. NodeBlockHeight <=. val (nodeBlockHeight best)
&&. t ^. NodeBlockChain !=. val 0
return best{ nodeBlockChain = 0 }