Chain.hs

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoFieldSelectors #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

-- |
-- Module      : Haskoin.Node.Chain
-- Copyright   : (c) Haskoin Developers
-- License     : MIT
-- Maintainer  : jprupp@protonmail.ch
-- Stability   : experimental
-- Portability : POSIX
--
-- The block header chain.
--
-- The chain process downloads block headers from connected peers, one peer at a
-- time, connects them to the headers it already has, and stores them in RocksDB.
-- It follows the chain with the most work, and publishes a 'ChainBestBlock'
-- event whenever the best block changes. Once the best block is recent (less
-- than two hours old), has at least the minimum chain work of the network, and
-- no peer is left to sync from, it publishes a single 'ChainSynced' event.
--
-- After a peer has delivered all its headers, it is asked to announce new
-- blocks with headers messages, which are fed back to the chain process by
-- "Haskoin.Node".
--
-- = Why it works this way
--
-- * __One peer at a time.__ Headers form a single chain, so asking several
--   peers for the same range at once would only download it several times.
--   The chain syncs from one peer and moves to the next when it is done or
--   times out, which also means every connected peer eventually gets a chance
--   to show a better chain.
--
-- * __Most work wins.__ The best chain is the one with the most accumulated
--   proof of work, not the longest or the first seen, as in every Bitcoin
--   implementation.
--
-- * __"Synced" has to be earned.__ Recent headers alone do not prove much: a
--   peer can feed a cheap chain with fresh timestamps. The chain only counts as
--   synced once its work reaches the network's minimum chain work, the same
--   guard Bitcoin Core uses before leaving initial block download. Applications
--   use 'ChainSynced' to start work that only makes sense at the tip, so a false
--   signal would be costly.
--
-- * __Headers are stored, not kept in memory.__ Storing them in RocksDB lets a
--   restart resume where it stopped instead of downloading the whole chain
--   again.
--
-- = Database
--
-- Headers are stored as 'BlockNode' values in the configured column family, or
-- the default one, under keys starting with byte @0x90@. The best block is
-- stored under key @0x91@ and a data version under key @0x92@. If the data
-- version does not match, keys @0x90@ and @0x91@ are deleted when the chain
-- starts. Applications that share the database must not use these prefixes.
module Haskoin.Node.Chain
  ( ChainConfig (..),
    ChainEvent (..),
    Chain,
    ChainT,
    runChainT,
    withChain,
    chainGetBlock,
    chainGetBest,
    chainGetAncestor,
    chainGetParents,
    chainGetSplitBlock,
    chainPeerConnected,
    chainPeerDisconnected,
    chainIsSynced,
    chainBlockMain,
    chainHeaders,
    chainSync,
  )
where

import Control.Monad (forM_, guard, when)
import Control.Monad.Trans.Reader
import Data.ByteString qualified as B
import Data.Function (on)
import Data.List (delete, nub)
import Data.Maybe (isJust, isNothing)
import Data.Serialize
import Data.String.Conversions (cs)
import Data.Time.Clock
import Data.Time.Clock.POSIX
import Data.Word (Word32)
import Database.RocksDB (ColumnFamily, DB)
import Database.RocksDB qualified as R
import Database.RocksDB.Query
import Haskoin hiding (Key)
import Haskoin.Node.Logger
import Haskoin.Node.Loop (loopForever)
import Haskoin.Node.Peer
import Haskoin.Node.PeerMgr (myVersion)
import NQE
import System.Random (randomRIO)
import UnliftIO
import UnliftIO.Concurrent (threadDelay)

-- | Configuration for chain syncing process.
data ChainConfig = ChainConfig
  { -- | database handle
    db :: !DB,
    -- | column family
    cf :: !(Maybe ColumnFamily),
    -- | network constants
    net :: !Network,
    -- | send header chain events here
    pub :: !(Publisher ChainEvent),
    -- | seconds to wait for headers from the syncing peer before it is
    -- disconnected
    timeout :: !NominalDiffTime,
    -- | log messages here
    logger :: !Logger
  }

-- | Messages handled by the chain process.
data ChainMessage
  = -- | a peer sent headers
    ChainHeaders !Peer ![BlockHeader]
  | -- | a peer completed the handshake
    ChainPeerConnected !Peer
  | -- | a peer disconnected
    ChainPeerDisconnected !Peer
  | -- | periodic tick to check the syncing peer for timeouts
    ChainPing
  | -- | reply once every previous message has been handled
    ChainSyncMsg !(Listen ())

-- | Events originating from chain syncing process.
data ChainEvent
  = -- | chain has new best block
    ChainBestBlock !BlockNode
  | -- | chain is in sync with the network; published only once, with the best
    -- block at that time
    ChainSynced !BlockNode
  deriving (Eq, Show)

-- | Handle to a running chain process. Obtain one with 'withChain', or from
-- the 'Haskoin.Node.Node' returned by 'Haskoin.Node.withNode'.
data Chain = Chain
  { -- | configuration
    config :: !ChainConfig,
    -- | mailbox of the chain process
    mailbox :: !(Mailbox ChainMessage),
    -- | syncing state
    state :: !(TVar ChainState)
  }

instance Eq Chain where
  (==) = (==) `on` (.mailbox)

-- | Database key for version.
data ChainDataVersionKey = ChainDataVersionKey
  deriving (Eq, Ord, Show)

instance Key ChainDataVersionKey

instance KeyValue ChainDataVersionKey Word32

instance Serialize ChainDataVersionKey where
  get = do
    guard . (== 0x92) =<< getWord8
    return ChainDataVersionKey
  put ChainDataVersionKey = putWord8 0x92

-- | State of the sync against one peer.
data ChainSync = ChainSync
  { -- | peer being synced against
    peer :: !Peer,
    -- | when it last sent headers, or when syncing started
    timestamp :: !UTCTime,
    -- | last header it sent, from which to continue syncing
    best :: !(Maybe BlockNode)
  }

-- | Mutable state for the header chain process.
data ChainState = ChainState
  { -- | peer to sync against and time of last received message
    syncing :: !(Maybe ChainSync),
    -- | queue of peers to sync against
    peers :: ![Peer],
    -- | has the header chain ever been considered synced?
    beenInSync :: !Bool
  }

-- | Key for block header in database.
newtype BlockHeaderKey = BlockHeaderKey BlockHash deriving (Eq, Show)

instance Serialize BlockHeaderKey where
  get = do
    guard . (== 0x90) =<< getWord8
    BlockHeaderKey <$> get
  put (BlockHeaderKey bh) = do
    putWord8 0x90
    put bh

-- | Key for best block in database.
data BestBlockKey = BestBlockKey deriving (Eq, Show)

instance KeyValue BlockHeaderKey BlockNode

instance KeyValue BestBlockKey BlockNode

instance Serialize BestBlockKey where
  get = do
    guard . (== 0x91) =<< getWord8
    return BestBlockKey
  put BestBlockKey = putWord8 0x91

-- | Monad transformer with access to a 'Chain'. It has a 'BlockHeaders'
-- instance, so the header functions of haskoin-core, such as 'getAncestor' and
-- 'splitPoint', can run in it against the database of the chain.
type ChainT m = ReaderT Chain m

-- | Run a 'ChainT' action against a chain.
runChainT :: ChainT m a -> Chain -> m a
runChainT = runReaderT

-- | Read and write headers in the database of a chain configuration. Orphan
-- instance.
instance (MonadIO m) => BlockHeaders (ReaderT ChainConfig m) where
  addBlockHeader bn = ReaderT $ \ChainConfig {db, cf} -> liftIO $ do
    case cf of
      Nothing -> insert db (BlockHeaderKey h) bn
      Just cf' -> insertCF db cf' (BlockHeaderKey h) bn
    where
      h = headerHash bn.header
  getBlockHeader bh = ReaderT $ \ChainConfig {db, cf} -> liftIO $ do
    retrieveCommon db cf (BlockHeaderKey bh)
  getBestBlockHeader = ReaderT $ \ChainConfig {db, cf} -> liftIO $ do
    retrieveCommon db cf BestBlockKey >>= \case
      Nothing -> error "Could not get best block from database"
      Just b -> return b
  setBestBlockHeader bn = ReaderT $ \ChainConfig {db, cf} -> liftIO $ do
    case cf of
      Nothing -> insert db BestBlockKey bn
      Just cf' -> insertCF db cf' BestBlockKey bn
  addBlockHeaders bns = ReaderT $ \ChainConfig {db, cf} -> liftIO $ do
    writeBatch db (map (f cf) bns)
    where
      h bn = headerHash bn.header
      f cf bn = case cf of
        Nothing -> insertOp (BlockHeaderKey (h bn)) bn
        Just cf' -> insertOpCF cf' (BlockHeaderKey (h bn)) bn

-- | Read and write headers in the database of a chain. Orphan instance.
instance (MonadIO m) => BlockHeaders (ChainT m) where
  addBlockHeader bn = withReaderT (.config) (addBlockHeader bn)
  getBlockHeader bh = withReaderT (.config) (getBlockHeader bh)
  getBestBlockHeader = withReaderT (.config) getBestBlockHeader
  setBestBlockHeader bn = withReaderT (.config) (setBestBlockHeader bn)
  addBlockHeaders bns = withReaderT (.config) (addBlockHeaders bns)

-- | Start the chain process and pass its handle to the given action. The process
-- is stopped when the action returns, and its exceptions are re-thrown in the
-- calling thread.
--
-- The database is initialised first: purged if its data version is old, and
-- seeded with the genesis block of the network if it has no best block. The
-- current best block is published as a 'ChainBestBlock' event on start.
withChain ::
  (MonadUnliftIO m) => ChainConfig -> (Chain -> m a) -> m a
withChain cfg action = do
  (inbox, mailbox) <- newMailbox
  st <-
    newTVarIO
      ChainState
        { syncing = Nothing,
          beenInSync = False,
          peers = []
        }
  let ch = Chain {config = cfg, mailbox = mailbox, state = st}
  initChainDB cfg
  withAsync (main_loop ch inbox) $ \a ->
    link a >> action ch
  where
    main_loop ch inbox =
      withSyncLoop ch.mailbox (run ch inbox)
    run ch inbox = do
      runReaderT getBestBlockHeader cfg
        >>= chainEvent cfg . ChainBestBlock
      loopForever $ do
        logDebug ch.config.logger "Awaiting event..."
        msg <- receive inbox
        chainConfigMessage ch msg

-- | Log and publish a chain event.
chainEvent :: (MonadIO m) => ChainConfig -> ChainEvent -> m ()
chainEvent cfg e = do
  case e of
    ChainBestBlock b ->
      logInfo
        cfg.logger
        ("Best block header at height " <> cs (show b.height))
    ChainSynced b ->
      logInfo
        cfg.logger
        ("Headers in sync at height " <> cs (show b.height))
  publish e cfg.pub

-- | Import headers sent by a peer. Disconnect the peer if they do not connect.
-- Publish a new best block if it changed. If the peer has no more headers, move
-- on to the next peer and check whether the chain is now in sync; otherwise ask
-- it for more.
processHeaders :: (MonadIO m) => Chain -> Peer -> [BlockHeader] -> m ()
processHeaders ch p hs = do
  let len = length hs
  logDebug
    ch.config.logger
    ("Processing " <> cs (show len) <> " headers from peer " <> p.label)
  let net = ch.config.net
  now <- liftIO getCurrentTime
  pbest <- runReaderT getBestBlockHeader ch.config
  importHeaders ch now hs >>= \case
    Nothing -> do
      logWarn
        ch.config.logger
        ("Could not connect headers from peer " <> p.label)
      killPeer p
    Just done -> do
      setLastReceived ch.state p
      best <- runReaderT getBestBlockHeader ch.config
      when (pbest.header /= best.header) $
        chainEvent ch.config (ChainBestBlock best)
      if done
        then do
          MSendHeaders `sendMessage` p
          finishPeer ch p
          syncNewPeer ch
          syncNotif ch
        else syncPeer ch p

-- | Start syncing against the next peer in the queue, unless a peer is already being synced.
syncNewPeer :: (MonadIO m) => Chain -> m ()
syncNewPeer ch =
  getSyncingPeer ch.state >>= \case
    Just _ -> return ()
    Nothing ->
      nextPeer ch >>= \case
        Nothing -> return ()
        Just p -> do
          logDebug ch.config.logger ("Syncing against peer " <> p.label)
          syncPeer ch p

-- | Publish a 'ChainSynced' event if the chain just became synced.
syncNotif :: (MonadIO m) => Chain -> m ()
syncNotif ch =
  notifySynced ch >>= \case
    False -> return ()
    True ->
      runReaderT getBestBlockHeader ch.config
        >>= chainEvent ch.config . ChainSynced

-- | Ask a peer for headers, continuing from the last header it sent, or from the
-- best block. Does nothing if another peer is being synced.
syncPeer :: (MonadIO m) => Chain -> Peer -> m ()
syncPeer ch p = do
  t <- liftIO getCurrentTime
  m <-
    chainSyncingPeer ch.state >>= \case
      Just ChainSync {peer = s, best = m}
        | p == s -> syncing_me t m
        | otherwise -> return Nothing
      Nothing -> syncing_new t
  forM_ m $ \g -> do
    logDebug
      ch.config.logger
      ("Requesting headers from peer " <> p.label)
    MGetHeaders g `sendMessage` p
  where
    syncing_new t =
      setSyncingPeer ch p >>= \case
        False -> return Nothing
        True -> do
          logDebug ch.config.logger ("Locked peer " <> p.label)
          h <- runReaderT getBestBlockHeader ch.config
          Just <$> syncHeaders ch t h p
    syncing_me t m = do
      h <- case m of
        Nothing -> runReaderT getBestBlockHeader ch.config
        Just h -> return h
      Just <$> syncHeaders ch t h p

-- | Handle a message sent to the chain process.
chainConfigMessage :: (MonadIO m) => Chain -> ChainMessage -> m ()
chainConfigMessage ch (ChainHeaders p hs) =
  processHeaders ch p hs
chainConfigMessage ch (ChainPeerConnected p) = do
  logDebug ch.config.logger ("Connected peer " <> p.label)
  addPeer ch.state p
  syncNewPeer ch
chainConfigMessage ch (ChainPeerDisconnected p) = do
  logDebug ch.config.logger ("Disconnected peer " <> p.label)
  finishPeer ch p
  syncNewPeer ch
chainConfigMessage _ (ChainSyncMsg r) =
  atomically (r ())
chainConfigMessage ch ChainPing = do
  logDebug ch.config.logger "Internal clock event"
  let to = ch.config.timeout
  now <- liftIO getCurrentTime
  chainSyncingPeer ch.state >>= \case
    Just ChainSync {peer = p, timestamp = t}
      | now `diffUTCTime` t > to -> do
          logWarn
            ch.config.logger
            ("Syncing peer " <> p.label <> " timed out")
          killPeer p
      | otherwise -> return ()
    Nothing -> syncNewPeer ch

-- | Run a loop in the background that sends a 'ChainPing' to the chain process
-- every 2 to 20 seconds.
withSyncLoop :: (MonadUnliftIO m) => Mailbox ChainMessage -> m a -> m a
withSyncLoop mbox mf =
  withAsync go $ \a ->
    link a >> mf
  where
    go = loopForever $ do
      delay <- randomRIO (2 * 10 ^ 6, 2 * 10 ^ 7)
      threadDelay delay
      ChainPing `send` mbox

-- | Version of the database.
dataVersion :: Word32
dataVersion = 1

-- | Initialize header database. If version is different from current, the
-- database is purged of conflicting elements first.
initChainDB :: (MonadIO m) => ChainConfig -> m ()
initChainDB cfg@ChainConfig {db, cf, net} = liftIO $ do
  ver <- retrieveCommon db cf ChainDataVersionKey
  when (ver /= Just dataVersion) $ purgeChainDB cfg
  case cf of
    Nothing -> insert db ChainDataVersionKey dataVersion
    Just cf' -> insertCF db cf' ChainDataVersionKey dataVersion
  retrieveCommon db cf BestBlockKey >>= \b ->
    when (isNothing (b :: Maybe BlockNode)) . flip runReaderT cfg $ do
      addBlockHeader (genesisNode net)
      setBestBlockHeader (genesisNode net)

-- | Purge database of elements having keys that may conflict with those used in
-- this module. Keys are deleted from the column family that holds the chain,
-- one at a time as the iterator walks them, so that memory use does not grow
-- with the size of the database.
purgeChainDB :: (MonadIO m) => ChainConfig -> m ()
purgeChainDB ChainConfig {db, cf} = liftIO $ do
  with_iter $ \it -> do
    R.iterSeek it (B.singleton 0x90)
    go it
  where
    with_iter = case cf of
      Nothing -> R.withIter db
      Just cf' -> R.withIterCF db cf'
    del k = case cf of
      Nothing -> R.delete db k
      Just cf' -> R.deleteCF db cf' k
    go it =
      R.iterKey it >>= \case
        Just k
          | B.take 1 k `elem` [B.singleton 0x90, B.singleton 0x91] -> do
              del k
              R.iterNext it
              go it
        _ -> return ()

-- | Import a bunch of continuous headers. Returns 'True' when the peer that
-- delivered them has no more headers to sync. That is the case when it sent
-- fewer than 'maxHeadersSize' (2000) headers, the most that one message may
-- hold. An empty headers message, which a peer sends when it has nothing
-- after the locator, counts as done too.
importHeaders ::
  (MonadIO m) => Chain -> UTCTime -> [BlockHeader] -> m (Maybe Bool)
importHeaders ch now hs =
  connect >>= \case
    Left e -> do
      logError ch.config.logger ("connectBlocks: " <> cs e)
      return Nothing
    Right bns
      | null bns -> return (Just True)
      | otherwise -> do
          bb <- get_last
          atomically . modifyTVar ch.state $ \s ->
            s {syncing = set_best bb <$> s.syncing}
          return (Just (length bns < fromIntegral maxHeadersSize))
  where
    set_best bb ChainSync {..} = ChainSync {best = bb, ..}
    timestamp = floor (utcTimeToPOSIXSeconds now)
    connect = runReaderT (connectBlocks ch.config.net timestamp hs) ch.config
    get_last = runReaderT (getBlockHeader (headerHash (last hs))) ch.config

-- | Check if best block header is in sync with the rest of the block chain by
-- comparing the best block with the current time, verifying that there are no
-- peers in the queue to be synced, and no peer is being synced at the moment.
-- This function will only return 'True' once. It should be used to decide
-- whether to notify other processes that the header chain has been synced. The
-- state of the chain will be flipped to synced when this function returns
-- 'True'.
--
-- The best block must also have the 'minimumChainWork' of the network.
-- Bitcoin Core requires the same before it leaves initial block download. A
-- chain with less work is not the real one, however recent its last block
-- is. Below that work 'connectBlocks' does not refuse cheap forks either.
notifySynced :: (MonadIO m) => Chain -> m Bool
notifySynced ch = do
  bb <- runReaderT getBestBlockHeader ch.config
  df <- (`diffUTCTime` block_time bb) <$> liftIO getCurrentTime
  atomically $ do
    s <- readTVar ch.state
    if
      | df > 7200 -> return False
      | bb.work < ch.config.net.minimumChainWork -> return False
      | isJust s.syncing -> return False
      | not (null s.peers) -> return False
      | s.beenInSync -> return False
      | otherwise -> do
          writeTVar ch.state s {beenInSync = True}
          return True
  where
    block_time =
      posixSecondsToUTCTime . fromIntegral . (.header.timestamp)

-- | Get next peer to sync against from the queue.
nextPeer :: (MonadIO m) => Chain -> m (Maybe Peer)
nextPeer ch = fmap (.peers) (readTVarIO ch.state) >>= go
  where
    go [] = return Nothing
    go (p : ps) =
      setSyncingPeer ch p >>= \case
        True -> return (Just p)
        False -> go ps

-- | Set a syncing peer and generate a 'GetHeaders' data structure with a block
-- locator to send to that peer for syncing.
syncHeaders ::
  (MonadIO m) => Chain -> UTCTime -> BlockNode -> Peer -> m GetHeaders
syncHeaders ch now bb p = do
  atomically $
    modifyTVar ch.state $ \s ->
      s
        { syncing =
            Just
              ChainSync
                { peer = p,
                  timestamp = now,
                  best = Nothing
                },
          peers = delete p s.peers
        }
  loc <- runReaderT (blockLocator bb) ch.config
  return
    GetHeaders
      { version = myVersion,
        locator = loc,
        stop = z
      }
  where
    z = "0000000000000000000000000000000000000000000000000000000000000000"

-- | Set the time of last received data to now if the given peer is the one
-- being synced against. Headers from other peers must not keep a silent
-- syncing peer from timing out.
setLastReceived :: (MonadIO m) => TVar ChainState -> Peer -> m ()
setLastReceived st p = do
  now <- liftIO getCurrentTime
  let f c@ChainSync {..}
        | peer == p = ChainSync {timestamp = now, ..}
        | otherwise = c
  atomically (modifyTVar st (\s -> s {syncing = f <$> s.syncing}))

-- | Add a new peer to the queue of peers to sync against.
addPeer :: (MonadIO m) => TVar ChainState -> Peer -> m ()
addPeer st p = do
  atomically (modifyTVar st (\s -> s {peers = nub (p : s.peers)}))

-- | Get syncing peer if there is one.
getSyncingPeer :: (MonadIO m) => TVar ChainState -> m (Maybe Peer)
getSyncingPeer st =
  readTVarIO st >>= \case
    ChainState {syncing = Just ChainSync {peer}} -> return (Just peer)
    _ -> return Nothing

-- | Reserve a peer with 'setBusy' and make it the syncing peer. Returns 'False'
-- if the peer is busy with something else.
setSyncingPeer :: (MonadIO m) => Chain -> Peer -> m Bool
setSyncingPeer ch p =
  setBusy p >>= \case
    False -> do
      logDebug
        ch.config.logger
        ("Could not lock peer: " <> p.label)
      return False
    True -> do
      logDebug ch.config.logger $
        ("Locked peer: " <> p.label)
      set_it
      return True
  where
    set_it = do
      now <- liftIO getCurrentTime
      atomically $ modifyTVar ch.state $ \s ->
        s
          { syncing =
              Just
                ChainSync
                  { peer = p,
                    timestamp = now,
                    best = Nothing
                  }
          }

-- | Remove a peer from the queue of peers to sync and unset the syncing peer if
-- it is set to the provided peer.
finishPeer :: (MonadIO m) => Chain -> Peer -> m ()
finishPeer ch p =
  remove_peer >>= \case
    False ->
      logDebug
        ch.config.logger
        ("Removed peer " <> p.label <> " from queue")
    True -> do
      logDebug
        ch.config.logger
        ("Releasing syncing peer " <> p.label)
      setFree p
  where
    remove_peer =
      atomically $
        readTVar ch.state >>= \s -> case s.syncing of
          Just ChainSync {peer = p'}
            | p == p' -> do
                unset_syncing
                return True
          _ -> do
            remove_from_queue
            return False
    unset_syncing =
      modifyTVar ch.state $ \x ->
        x {syncing = Nothing}
    remove_from_queue =
      modifyTVar ch.state $ \x ->
        x {peers = delete p x.peers}

-- | Return syncing peer data.
chainSyncingPeer :: (MonadIO m) => TVar ChainState -> m (Maybe ChainSync)
chainSyncingPeer st = (.syncing) <$> readTVarIO st

-- | Get a block header from the block chain. Returns headers on side chains
-- too; use 'chainBlockMain' to check whether a block is in the main chain.
chainGetBlock :: (MonadIO m) => Chain -> BlockHash -> m (Maybe BlockNode)
chainGetBlock ch bh = runReaderT (getBlockHeader bh) ch.config

-- | Get best block header from chain process.
chainGetBest :: (MonadIO m) => Chain -> m BlockNode
chainGetBest ch = runReaderT getBestBlockHeader ch.config

-- | Get ancestor of 'BlockNode' at 'BlockHeight' from chain process. Returns
-- 'Nothing' if the height is above that of the node.
chainGetAncestor ::
  (MonadIO m) => Chain -> BlockHeight -> BlockNode -> m (Maybe BlockNode)
chainGetAncestor ch h bn = runReaderT (getAncestor h bn) ch.config

-- | Get parents of 'BlockNode' starting at 'BlockHeight' from chain process.
-- The result is in ascending order, from the block at the given height up to
-- the parent of the given node, which is not included.
chainGetParents ::
  (MonadIO m) => Chain -> BlockHeight -> BlockNode -> m [BlockNode]
chainGetParents ch height top =
  go [] top
  where
    go acc b
      | height >= b.height = return acc
      | otherwise = do
          m <- chainGetBlock ch b.header.prev
          case m of
            Nothing -> return acc
            Just p -> go (p : acc) p

-- | Get last common block from chain process: the most recent block that is an
-- ancestor of both nodes.
chainGetSplitBlock ::
  (MonadIO m) => Chain -> BlockNode -> BlockNode -> m BlockNode
chainGetSplitBlock ch l r = runReaderT (splitPoint l r) ch.config

-- | Notify chain that a new peer is connected. It is added to the queue of
-- peers to sync against.
chainPeerConnected :: (MonadIO m) => Chain -> Peer -> m ()
chainPeerConnected ch p =
  ChainPeerConnected p `send` ch.mailbox

-- | Notify chain that a peer has disconnected.
chainPeerDisconnected :: (MonadIO m) => Chain -> Peer -> m ()
chainPeerDisconnected ch p =
  ChainPeerDisconnected p `send` ch.mailbox

-- | Is given 'BlockHash' in the main chain?
chainBlockMain :: (MonadIO m) => Chain -> BlockHash -> m Bool
chainBlockMain ch bh =
  chainGetBest ch >>= \bb ->
    chainGetBlock ch bh >>= \case
      Nothing ->
        return False
      bm@(Just bn) ->
        (== bm) <$> chainGetAncestor ch bn.height bb

-- | Is chain in sync with network? Once 'True', it stays 'True' even if the
-- chain falls behind later.
chainIsSynced :: (MonadIO m) => Chain -> m Bool
chainIsSynced ch =
  (.beenInSync) <$> readTVarIO (ch.state)

-- | Peer sends a bunch of headers to the chain process. "Haskoin.Node" calls
-- this for every headers message received from an online peer.
chainHeaders :: (MonadIO m) => Chain -> Peer -> [BlockHeader] -> m ()
chainHeaders ch p hs =
  ChainHeaders p hs `send` ch.mailbox

-- | Wait until the chain process has handled every message sent to it before.
chainSync :: (MonadIO m) => Chain -> m ()
chainSync ch = ChainSyncMsg `query` ch.mailbox