HeaderTree.hs

module Network.Haskoin.Node.HeaderTree
( HeaderTree(..)
, BlockHeaderNode(..)
, BlockChainAction(..)
, BlockHeight
, Timestamp
, initHeaderTree
, connectHeader
, connectHeaders
, commitAction
, isBestChain
, isChainReorg
, isSideChain
, isKnownChain
, blockLocator
, blockLocatorHeight
, blockLocatorSide
, blockLocatorPartial
, getNodeWindow
, bestBlockHeaderHeight
, getBlockHeaderHeight
, getNodeAtTimestamp
, genesisNode
, getParentNode
) where

import Control.Monad (foldM, when, unless, liftM, (<=<), forM, forM_)
import Control.Monad.Trans (lift, liftIO, MonadIO)
import Control.Monad.Trans.Either (EitherT, left, runEitherT)
import Control.Monad.Reader (MonadReader(..), ReaderT, ask)
import Control.DeepSeq (NFData(..))

import Data.Word (Word32)
import Data.Bits (shiftL)
import Data.Maybe (fromMaybe, isNothing, isJust, catMaybes)
import Data.List (sort)
import Data.Binary.Get (getWord32le)
import Data.Binary.Put (putWord32le)
import Data.Default (def)
import qualified Data.Binary as B (Binary, get, put)
import qualified Data.ByteString as BS (ByteString, reverse, append)

import qualified Database.LevelDB.Base as L (DB, get, put)

import Network.Haskoin.Block
import Network.Haskoin.Constants
import Network.Haskoin.Util
import Network.Haskoin.Node.Checkpoints

type BlockHeight = Word32
type Timestamp = Word32

class Monad m => HeaderTree m where
    getBlockHeaderNode     :: BlockHash -> m (Maybe BlockHeaderNode)
    putBlockHeaderNode     :: BlockHeaderNode -> m ()
    -- The height is only updated when the node is part of the main chain.
    -- Side chains are not indexed by their height.
    putBlockHeaderHeight   :: BlockHeaderNode -> m ()
    getBlockHeaderByHeight :: BlockHeight -> m (Maybe BlockHeaderNode)
    getBestBlockHeader     :: m BlockHeaderNode
    setBestBlockHeader     :: BlockHeaderNode -> m ()

-- | Data type representing a BlockHeader node in the header chain. It
-- contains additional data such as the chain work and chain height for this
-- node.
data BlockHeaderNode = BlockHeaderNode
    { nodeBlockHash    :: !BlockHash
    , nodeHeader       :: !BlockHeader
    , nodeHeaderHeight :: !BlockHeight
    , nodeChainWork    :: !Integer
    , nodeChild        :: !(Maybe BlockHash)
    , nodeMedianTimes  :: ![Timestamp]
    , nodeMinWork      :: !Word32 -- Only used for testnet
    } deriving (Show, Read, Eq)

instance NFData BlockHeaderNode where
    rnf BlockHeaderNode{..} =
        rnf nodeBlockHash `seq`
        rnf nodeHeader `seq`
        rnf nodeHeaderHeight `seq`
        rnf nodeChainWork `seq`
        rnf nodeChild `seq`
        rnf nodeMedianTimes `seq`
        rnf nodeMinWork

instance B.Binary BlockHeaderNode where

    get = do
        nodeBlockHash    <- B.get
        nodeHeader       <- B.get
        nodeHeaderHeight <- getWord32le
        nodeChainWork    <- B.get
        nodeChild        <- B.get
        nodeMedianTimes  <- B.get
        nodeMinWork      <- B.get
        return BlockHeaderNode{..}

    put BlockHeaderNode{..} = do
        B.put       nodeBlockHash
        B.put       nodeHeader
        putWord32le nodeHeaderHeight
        B.put       nodeChainWork
        B.put       nodeChild
        B.put       nodeMedianTimes
        B.put       nodeMinWork

data BlockChainAction
    = BestChain  { actionNodes     :: ![BlockHeaderNode] }
    | ChainReorg { actionSplitNode :: !BlockHeaderNode
                 , actionOldNodes  :: ![BlockHeaderNode]
                 , actionNodes     :: ![BlockHeaderNode]
                 }
    | SideChain  { actionNodes     :: ![BlockHeaderNode] }
    | KnownChain { actionNodes     :: ![BlockHeaderNode] }
    deriving (Read, Show, Eq)

instance NFData BlockChainAction where
    rnf bca = case bca of
        BestChain ns -> rnf ns
        ChainReorg s os ns -> rnf s `seq` rnf os `seq` rnf ns
        KnownChain ns -> rnf ns
        SideChain ns -> rnf ns

-- | Returns True if the action is a best chain
isBestChain :: BlockChainAction -> Bool
isBestChain (BestChain _) = True
isBestChain _             = False

-- | Returns True if the action is a chain reorg
isChainReorg :: BlockChainAction -> Bool
isChainReorg ChainReorg{} = True
isChainReorg _            = False

-- | Returns True if the action is a side chain
isSideChain :: BlockChainAction -> Bool
isSideChain (SideChain _) = True
isSideChain _             = False

-- | Returns True if the action is a known chain
isKnownChain :: BlockChainAction -> Bool
isKnownChain (KnownChain _) = True
isKnownChain _              = False

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

-- | Genesis BlockHeaderNode
genesisNode :: BlockHeaderNode
genesisNode = BlockHeaderNode
    { nodeBlockHash    = headerHash genesisHeader
    , nodeHeader       = genesisHeader
    , nodeHeaderHeight = 0
    , nodeChainWork    = headerWork genesisHeader
    , nodeChild        = Nothing
    , nodeMedianTimes  = [blockTimestamp genesisHeader]
    , nodeMinWork      = blockBits genesisHeader
    }

-- | Initialize the block header chain by inserting the genesis block if
-- it doesn't already exist.
initHeaderTree :: HeaderTree m => m ()
initHeaderTree = do
    genM <- getBlockHeaderNode $ nodeBlockHash genesisNode
    when (isNothing genM) $ do
        putBlockHeaderNode genesisNode
        putBlockHeaderHeight genesisNode
        setBestBlockHeader genesisNode

-- A more efficient way of connecting a list of BlockHeaders than connecting
-- them individually. The work check will only be done once for the whole
-- chain. The list of BlockHeaders have to form a valid chain, linked by their
-- parents.
connectHeaders :: HeaderTree m
               => [BlockHeader]
               -> Timestamp
               -> Bool
               -> m (Either String BlockChainAction)
connectHeaders bhs adjustedTime commit
    | null bhs = return $ Left "Invalid empty BlockHeaders in connectHeaders"
    | validChain bhs = runEitherT $ do
        newNodes <- forM bhs $ \bh -> do
            parNode <- verifyBlockHeader bh adjustedTime
            lift $ storeBlockHeader bh parNode
        -- Best header will only be updated if we have no errors
        lift $ evalNewChain commit newNodes
    | otherwise = return $ Left "BlockHeaders do not form a valid chain."
  where
    validChain (a:b:xs) =  prevBlock b == headerHash a && validChain (b:xs)
    validChain [_] = True
    validChain _ = False

-- | Connect a block header to this block header chain. Corresponds to bitcoind
-- function ProcessBlockHeader and AcceptBlockHeader in main.cpp.
connectHeader :: HeaderTree m
              => BlockHeader
              -> Timestamp
              -> Bool
              -> m (Either String BlockChainAction)
connectHeader bh adjustedTime commit = runEitherT $ do
    parNode <- verifyBlockHeader bh adjustedTime
    lift $ evalNewChain commit . (: []) =<< storeBlockHeader bh parNode

evalNewChain :: HeaderTree m
             => Bool
             -> [BlockHeaderNode]
             -> m BlockChainAction
evalNewChain commit newNodes = do
    currentHead <- getBestBlockHeader
    action <- go =<< findSplitNode currentHead (last newNodes)
    when commit $ commitAction action
    return action
  where
    go (split, old, new)
        | null old && not (null new) = return $ BestChain new
        | not (null old) && not (null new) =
            return $ if nodeChainWork (last new) > nodeChainWork (last old)
                  then ChainReorg split old new
                  else SideChain $ split : new
        | otherwise = return $ KnownChain newNodes

-- | Update the best block header of the action in the header tree
commitAction :: HeaderTree m => BlockChainAction -> m ()
commitAction action = do
    currentHead <- getBestBlockHeader
    case action of
        BestChain nodes -> unless (null nodes) $ do
            updateChildren $ currentHead:nodes
            forM_ nodes putBlockHeaderHeight
            setBestBlockHeader $ last nodes
        ChainReorg s _ ns -> unless (null ns) $ do
            updateChildren $ s:ns
            forM_ ns putBlockHeaderHeight
            setBestBlockHeader $ last ns
        KnownChain _ -> return ()
        SideChain _ -> return ()
  where
    updateChildren (a:b:xs) = do
        putBlockHeaderNode a{ nodeChild = Just $ nodeBlockHash b }
        updateChildren (b:xs)
    updateChildren _ = return ()

-- TODO: Add DOS return values
verifyBlockHeader :: HeaderTree m
                  => BlockHeader
                  -> Timestamp
                  -> EitherT String m BlockHeaderNode
verifyBlockHeader bh adjustedTime  = do
    unless (isValidPOW bh) $ left "Invalid proof of work"

    unless (blockTimestamp bh <= adjustedTime + 2 * 60 * 60) $
        left "Invalid header timestamp"

    parNodeM <- lift $ getBlockHeaderNode $ prevBlock bh
    parNode <- maybe (left "Parent block not found") return parNodeM

    nextWork <- lift $ nextWorkRequired parNode bh
    unless (blockBits bh == nextWork) $ left "Incorrect work transition (bits)"

    let sortedMedians = sort $ nodeMedianTimes parNode
        medianTime    = sortedMedians !! (length sortedMedians `div` 2)
    when (blockTimestamp bh <= medianTime) $ left "Block timestamp is too early"

    chkPointM <- lift lastSeenCheckpoint
    let newHeight = nodeHeaderHeight parNode + 1
    unless (maybe True ((fromIntegral newHeight >) . fst) chkPointM) $
        left "Rewriting pre-checkpoint chain"

    unless (verifyCheckpoint (fromIntegral newHeight) bid) $
        left "Rejected by checkpoint lock-in"

    -- All block of height 227836 or more use version 2 in prodnet
    -- TODO: Find out the value here for testnet
    when (  networkName == "prodnet"
         && blockVersion bh == 1
         && nodeHeaderHeight parNode + 1 >= 227836) $
        left "Rejected version=1 block"

    return parNode
  where
    bid = headerHash bh

-- Build a new block header and store it
storeBlockHeader :: HeaderTree m
                 => BlockHeader
                 -> BlockHeaderNode
                 -> m BlockHeaderNode
storeBlockHeader bh parNode = do
    let nodeBlockHash    = bid
        nodeHeader       = bh
        nodeHeaderHeight = newHeight
        nodeChainWork    = newWork
        nodeChild        = Nothing
        nodeMedianTimes  = newMedian
        nodeMinWork      = minWork
        newNode          = BlockHeaderNode{..}
    prevM <- getBlockHeaderNode bid
    case prevM of
        Just prev -> return prev
        Nothing   -> putBlockHeaderNode newNode >> return newNode
  where
    bid       = headerHash bh
    newHeight = nodeHeaderHeight parNode + 1
    newWork   = nodeChainWork parNode + headerWork bh
    newMedian = blockTimestamp bh : take 10 (nodeMedianTimes parNode)
    isDiffChange = newHeight `mod` diffInterval == 0
    isNotLimit   = blockBits bh /= encodeCompact powLimit
    minWork | not allowMinDifficultyBlocks = 0
            | isDiffChange || isNotLimit   = blockBits bh
            | otherwise                    = nodeMinWork parNode

-- | Return the window of nodes starting from the child of the given node.
-- Child links are followed to build the window. If the window ends in an
-- orphaned chain, we backtrack and return the window in the main chain.
-- The result is returned in a BlockChainAction to know if we had to
-- backtrack into the main chain or not.
getNodeWindow :: HeaderTree m
              => BlockHash -> Int -> m (Maybe BlockChainAction)
getNodeWindow bh cnt = getBlockHeaderNode bh >>= \nodeM -> case nodeM of
        Just node -> go [] cnt node
        Nothing -> return Nothing
  where
    go [] 0 _  = return Nothing
    go acc 0 _ = return $ Just $ BestChain $ reverse acc
    go acc i node = getChildNode node >>= \childM -> case childM of
        Just child -> go (child:acc) (i-1) child
        Nothing -> do
            -- We are at the end of our chain. Check if there is a better chain.
            currentHead <- getBestBlockHeader
            if nodeChainWork currentHead > nodeChainWork node
                -- We got stuck in an orphan chain. We need to backtrack.
                then findMainChain currentHead
                -- We are at the end of the main chain
                else return $ if null acc
                    then Nothing
                    else Just $ BestChain $ reverse acc
    findMainChain currentHead = do
        -- Compute the split point from the original input node so that the old
        -- chain doesn't contain blocks beyond the original node.
        node <- fromMaybe e <$> getBlockHeaderNode bh
        (split, old, new) <- findSplitNode node currentHead
        return $ Just $ ChainReorg split old $ take cnt new
    e = error "getNodeWindow: Could not get block header node"

-- Find the first node right after the given timestamp
getNodeAtTimestamp :: HeaderTree m
                   => Timestamp
                   -> m (Maybe BlockHeaderNode)
getNodeAtTimestamp ts = do
    best <- getBestBlockHeader
    if ts < blockTimestamp (nodeHeader best)
        -- there is a solution. Perform a binary search.
        then go 0 $ nodeHeaderHeight best
        -- There is no solution.
        else return Nothing
  where
    go a b
        | a == b = getBlockHeaderByHeight a
        | otherwise = do
            -- compute the middle point
            let m = a + ((b - a) `div` 2)
            nodeM <- getBlockHeaderByHeight m
            case nodeM of
                Just node -> if ts < blockTimestamp (nodeHeader node)
                    -- The block is after the timestamp. The block could be the
                    -- solution, or the solution is smaller.
                    then go a m
                    -- The block is before the timestamp. The solution is
                    -- striclty higher than m.
                    else go (m+1) b
                _ -> error $ unwords
                    [ "getNodeAtTimestamp: Possibly corrupted chain"
                    , "at height", show m
                    ]

-- | Find the split point between two nodes. It also returns the two partial
-- chains leading from the split point to the respective nodes.
findSplitNode :: HeaderTree m
              => BlockHeaderNode
              -> BlockHeaderNode
              -> m (BlockHeaderNode, [BlockHeaderNode], [BlockHeaderNode])
findSplitNode =
    go [] []
  where
    go xs ys x y
        | nodeBlockHash x == nodeBlockHash y = return (x, xs, ys)
        | nodeHeaderHeight x > nodeHeaderHeight y = do
            par <- fromMaybe e <$> getParentNode x
            go (x:xs) ys par y
        | otherwise = do
            par <- fromMaybe e <$> getParentNode y
            go xs (y:ys) x par
    e = error "findSplitNode: Could not get parent node"

-- | Finds the parent of a BlockHeaderNode
getParentNode :: HeaderTree m => BlockHeaderNode -> m (Maybe BlockHeaderNode)
getParentNode node
    | p == z    = return Nothing
    | otherwise = getBlockHeaderNode p
  where
    p = prevBlock $ nodeHeader node
    z = "0000000000000000000000000000000000000000000000000000000000000000"

-- | Finds the child of a BlockHeaderNode if it exists. If a node has
-- multiple children, this function will always return the child on the
-- main branch.
getChildNode :: HeaderTree m => BlockHeaderNode -> m (Maybe BlockHeaderNode)
getChildNode node = case nodeChild node of
    Just child -> getBlockHeaderNode child
    Nothing    -> return Nothing

-- | Get the last checkpoint that we have seen
lastSeenCheckpoint :: HeaderTree m => m (Maybe (Int, BlockHash))
lastSeenCheckpoint =
    go $ reverse checkpointList
  where
    go ((i, chk):xs) = do
        existsChk <- liftM isJust $ getBlockHeaderNode chk
        if existsChk then return $ Just (i, chk) else go xs
    go [] = return Nothing

-- | Returns the work required for a BlockHeader given the previous
-- BlockHeaderNode. This function coresponds to bitcoind function
-- GetNextWorkRequired in main.cpp.
nextWorkRequired :: HeaderTree m => BlockHeaderNode -> BlockHeader -> m Word32
nextWorkRequired lastNode bh
    -- Genesis block
    | prevBlock (nodeHeader lastNode) == z = return $ encodeCompact powLimit
    -- Only change the difficulty once per interval
    | (nodeHeaderHeight lastNode + 1) `mod` diffInterval /= 0 = return $
        if allowMinDifficultyBlocks
            then minPOW
            else blockBits $ nodeHeader lastNode
    | otherwise = do
        -- TODO: Can this break if there are not enough blocks in the chain?
        firstNode <- foldM (flip ($)) lastNode fs
        let lastTs = blockTimestamp $ nodeHeader firstNode
        return $ workFromInterval lastTs (nodeHeader lastNode)
  where
    len   = fromIntegral diffInterval - 1
    fs    = replicate len (liftM (fromMaybe e) . getParentNode)
    e = error "nextWorkRequired: Could not get parent node"
    delta = targetSpacing * 2
    minPOW
        | blockTimestamp bh > blockTimestamp (nodeHeader lastNode) + delta =
            encodeCompact powLimit
        | otherwise = nodeMinWork lastNode
    z = "0000000000000000000000000000000000000000000000000000000000000000"

-- | Computes the work required for the next block given a timestamp and the
-- current block. The timestamp should come from the block that matched the
-- last jump in difficulty (spaced out by 2016 blocks in prodnet).
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

-- | Returns a BlockLocator object (newest block first, genesis at the end)
blockLocator :: HeaderTree m => m BlockLocator
blockLocator = bestBlockHeaderHeight >>= blockLocatorHeight

-- | Returns a BlockLocator object for a given block height on the main chain.
blockLocatorHeight :: HeaderTree m => BlockHeight -> m BlockLocator
blockLocatorHeight height = do
    -- Take only indices > 0 to avoid the genesis block
    let is = takeWhile (> (0 :: Int)) $
            [h, (h - 1) .. (h - 9)] ++ [(h - 10) - 2^x | x <- [(0 :: Int)..]]
    ns <- liftM catMaybes $ forM (map fromIntegral is) getBlockHeaderByHeight
    return $ map nodeBlockHash ns ++ [headerHash genesisHeader]
  where
    h = fromIntegral height

-- | Build a block locator starting from a side chain. We do not have access
-- to the height index for the portion of the side chain so we build the
-- part in the side chain manually, then use the block height index for the
-- rest of the locator once we're back on the main chain.
blockLocatorSide :: HeaderTree m => BlockChainAction -> m BlockLocator
blockLocatorSide action = case action of
    SideChain (split:nodes) -> do
        mainLoc <- blockLocatorHeight $ nodeHeaderHeight split
        return $ take 10 (map nodeBlockHash $ reverse nodes) ++ mainLoc
    _ -> error "blockLocatorSide: Invalid blockchain action provided"

-- | Returns a partial BlockLocator object.
blockLocatorPartial :: HeaderTree m => Int -> m BlockLocator
blockLocatorPartial i
    | i < 1 = error "Locator length must be greater than 0"
    | otherwise = do
        h <- getBestBlockHeader
        liftM (map nodeBlockHash . reverse) $ go [] i h
  where
    go acc 1 node = return $ node:acc
    go acc step node = getParentNode node >>= \parM -> case parM of
        Just par -> go (node:acc) (step - 1) par
        Nothing  -> return $ node:acc

bestBlockHeaderHeight :: HeaderTree m => m BlockHeight
bestBlockHeaderHeight = liftM nodeHeaderHeight getBestBlockHeader

getBlockHeaderHeight :: HeaderTree m => BlockHash -> m (Maybe BlockHeight)
getBlockHeaderHeight = return . fmap nodeHeaderHeight <=< getBlockHeaderNode

-- | 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 :: BlockHeader -> Bool
isValidPOW bh
    | target <= 0 || target > powLimit = False
    | otherwise = headerPOW bh <= fromIntegral target
  where
    target = decodeCompact $ blockBits bh

-- | Returns the proof of work of a block header as an Integer number.
headerPOW :: BlockHeader -> Integer
headerPOW =  bsToInteger . BS.reverse . encode' . headerHash

-- | 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      = decodeCompact (blockBits bh)
    largestHash = 1 `shiftL` 256

{- Default LevelDB implementation -}

blockHashKey :: BlockHash -> BS.ByteString
blockHashKey bid = "b_" `BS.append` encode' bid

bestBlockKey :: BS.ByteString
bestBlockKey = "bestblockheader_"

heightKey :: BlockHeight -> BS.ByteString
heightKey h = "h_" `BS.append` encode' h

-- Get a node which is directly referenced by the key
getLevelDBNode :: MonadIO m
               => BS.ByteString -> ReaderT L.DB m (Maybe BlockHeaderNode)
getLevelDBNode key = do
    db <- ask
    resM <- liftIO $ L.get db def key
    return $ decodeToMaybe =<< resM

-- Get a node that has 1 level of indirection
getLevelDBNode' :: MonadIO m
                => BS.ByteString -> ReaderT L.DB m (Maybe BlockHeaderNode)
getLevelDBNode' key = do
    db <- ask
    resM <- liftIO $ L.get db def key
    maybe (return Nothing) getLevelDBNode resM

instance MonadIO m => HeaderTree (ReaderT L.DB m) where
    getBlockHeaderNode = getLevelDBNode . blockHashKey
    putBlockHeaderNode node = do
        db <- ask
        liftIO $ L.put db def (blockHashKey $ nodeBlockHash node) $ encode' node
    getBlockHeaderByHeight = getLevelDBNode' . heightKey
    putBlockHeaderHeight node = do
        db <- ask
        let val = blockHashKey $ nodeBlockHash node
        liftIO $ L.put db def (heightKey $ nodeHeaderHeight node) val
    getBestBlockHeader = do
        db <- ask
        keyM <- liftIO $ L.get db def bestBlockKey
        case keyM of
            Just key -> fromMaybe e <$> getLevelDBNode key
            Nothing  -> error
                "GetBestBlockHeader: Best block header does not exist"
      where
        e = error "getBestBlockHeader: Could not get LevelDB node"
    setBestBlockHeader node = do
        db <- ask
        liftIO $ L.put db def bestBlockKey $ blockHashKey $ nodeBlockHash node