{-# LANGUAGE ConstraintKinds           #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE FlexibleInstances         #-}
{-# LANGUAGE LambdaCase                #-}
{-# LANGUAGE MultiParamTypeClasses     #-}
{-# LANGUAGE OverloadedStrings         #-}
{-# LANGUAGE TemplateHaskell           #-}
{-# LANGUAGE UndecidableInstances      #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Haskoin.Node.Chain
    ( ChainConfig (..)
    , ChainEvent (..)
    , Chain
    , withChain
    , chainGetBlock
    , chainGetBest
    , chainGetAncestor
    , chainGetParents
    , chainGetSplitBlock
    , chainPeerConnected
    , chainPeerDisconnected
    , chainIsSynced
    , chainBlockMain
    , chainHeaders
    ) where

import           Control.Monad             (forM_, forever, guard, when)
import           Control.Monad.Except      (runExceptT, throwError)
import           Control.Monad.Logger      (MonadLoggerIO, logDebugS, logErrorS,
                                            logInfoS)
import           Control.Monad.Reader      (MonadReader, ReaderT (..), asks,
                                            runReaderT)
import           Control.Monad.Trans       (lift)
import           Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)
import qualified Data.ByteString           as B
import           Data.Function             (on)
import           Data.List                 (delete, nub)
import           Data.Maybe                (isJust, isNothing)
import           Data.Serialize            (Serialize, get, getWord8, put,
                                            putWord8)
import           Data.String.Conversions   (cs)
import           Data.Time.Clock           (NominalDiffTime, UTCTime,
                                            diffUTCTime, getCurrentTime)
import           Data.Time.Clock.POSIX     (posixSecondsToUTCTime,
                                            utcTimeToPOSIXSeconds)
import           Data.Word                 (Word32)
import           Database.RocksDB          (ColumnFamily, DB)
import qualified Database.RocksDB          as R
import           Database.RocksDB.Query    (Key, KeyValue, insert, insertCF,
                                            insertOp, insertOpCF,
                                            retrieveCommon, writeBatch)
import           Haskoin                   (BlockHash, BlockHeader (..),
                                            BlockHeaders (..), BlockHeight,
                                            BlockNode (..), GetHeaders (..),
                                            Message (..), Network, blockLocator,
                                            connectBlocks, genesisNode,
                                            getAncestor, headerHash, splitPoint)
import           Haskoin.Node.Manager      (myVersion)
import           Haskoin.Node.Peer
import           NQE                       (Mailbox, Publisher, newMailbox,
                                            publish, receive, send)
import           System.Random             (randomRIO)
import           UnliftIO                  (MonadIO, MonadUnliftIO, TVar,
                                            atomically, liftIO, link,
                                            modifyTVar, newTVarIO, readTVar,
                                            readTVarIO, withAsync, writeTVar)
import           UnliftIO.Concurrent       (threadDelay)

-- | Mailbox for chain header syncing process.
data Chain = Chain { Chain -> Mailbox ChainMessage
chainMailbox :: !(Mailbox ChainMessage)
                   , Chain -> ChainReader
chainReader  :: !ChainReader
                   }

instance Eq Chain where
    == :: Chain -> Chain -> Bool
(==) = Mailbox ChainMessage -> Mailbox ChainMessage -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Mailbox ChainMessage -> Mailbox ChainMessage -> Bool)
-> (Chain -> Mailbox ChainMessage) -> Chain -> Chain -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Chain -> Mailbox ChainMessage
chainMailbox

-- | Configuration for chain syncing process.
data ChainConfig =
    ChainConfig
        { ChainConfig -> DB
chainConfDB           :: !DB
          -- ^ database handle
        , ChainConfig -> Maybe ColumnFamily
chainConfColumnFamily :: !(Maybe ColumnFamily)
          -- ^ column family
        , ChainConfig -> Network
chainConfNetwork      :: !Network
          -- ^ network constants
        , ChainConfig -> Publisher ChainEvent
chainConfEvents       :: !(Publisher ChainEvent)
          -- ^ send header chain events here
        , ChainConfig -> NominalDiffTime
chainConfTimeout      :: !NominalDiffTime
          -- ^ timeout in seconds
        }

data ChainMessage
    = ChainHeaders !Peer ![BlockHeader]
    | ChainPeerConnected !Peer
    | ChainPeerDisconnected !Peer
    | ChainPing

-- | Events originating from chain syncing process.
data ChainEvent
    = ChainBestBlock !BlockNode
      -- ^ chain has new best block
    | ChainSynced !BlockNode
      -- ^ chain is in sync with the network
    deriving (ChainEvent -> ChainEvent -> Bool
(ChainEvent -> ChainEvent -> Bool)
-> (ChainEvent -> ChainEvent -> Bool) -> Eq ChainEvent
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ChainEvent -> ChainEvent -> Bool
$c/= :: ChainEvent -> ChainEvent -> Bool
== :: ChainEvent -> ChainEvent -> Bool
$c== :: ChainEvent -> ChainEvent -> Bool
Eq, Int -> ChainEvent -> ShowS
[ChainEvent] -> ShowS
ChainEvent -> String
(Int -> ChainEvent -> ShowS)
-> (ChainEvent -> String)
-> ([ChainEvent] -> ShowS)
-> Show ChainEvent
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ChainEvent] -> ShowS
$cshowList :: [ChainEvent] -> ShowS
show :: ChainEvent -> String
$cshow :: ChainEvent -> String
showsPrec :: Int -> ChainEvent -> ShowS
$cshowsPrec :: Int -> ChainEvent -> ShowS
Show)

type MonadChain m =
    ( MonadLoggerIO m
    , MonadUnliftIO m
    , MonadReader ChainReader m )

-- | Reader for header synchronization code.
data ChainReader = ChainReader
    { ChainReader -> ChainConfig
myConfig   :: !ChainConfig
      -- ^ placeholder for upstream data
    , ChainReader -> TVar ChainState
chainState :: !(TVar ChainState)
      -- ^ mutable state for header synchronization
    }

-- | Database key for version.
data ChainDataVersionKey = ChainDataVersionKey
    deriving (ChainDataVersionKey -> ChainDataVersionKey -> Bool
(ChainDataVersionKey -> ChainDataVersionKey -> Bool)
-> (ChainDataVersionKey -> ChainDataVersionKey -> Bool)
-> Eq ChainDataVersionKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ChainDataVersionKey -> ChainDataVersionKey -> Bool
$c/= :: ChainDataVersionKey -> ChainDataVersionKey -> Bool
== :: ChainDataVersionKey -> ChainDataVersionKey -> Bool
$c== :: ChainDataVersionKey -> ChainDataVersionKey -> Bool
Eq, Eq ChainDataVersionKey
Eq ChainDataVersionKey
-> (ChainDataVersionKey -> ChainDataVersionKey -> Ordering)
-> (ChainDataVersionKey -> ChainDataVersionKey -> Bool)
-> (ChainDataVersionKey -> ChainDataVersionKey -> Bool)
-> (ChainDataVersionKey -> ChainDataVersionKey -> Bool)
-> (ChainDataVersionKey -> ChainDataVersionKey -> Bool)
-> (ChainDataVersionKey
    -> ChainDataVersionKey -> ChainDataVersionKey)
-> (ChainDataVersionKey
    -> ChainDataVersionKey -> ChainDataVersionKey)
-> Ord ChainDataVersionKey
ChainDataVersionKey -> ChainDataVersionKey -> Bool
ChainDataVersionKey -> ChainDataVersionKey -> Ordering
ChainDataVersionKey -> ChainDataVersionKey -> ChainDataVersionKey
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ChainDataVersionKey -> ChainDataVersionKey -> ChainDataVersionKey
$cmin :: ChainDataVersionKey -> ChainDataVersionKey -> ChainDataVersionKey
max :: ChainDataVersionKey -> ChainDataVersionKey -> ChainDataVersionKey
$cmax :: ChainDataVersionKey -> ChainDataVersionKey -> ChainDataVersionKey
>= :: ChainDataVersionKey -> ChainDataVersionKey -> Bool
$c>= :: ChainDataVersionKey -> ChainDataVersionKey -> Bool
> :: ChainDataVersionKey -> ChainDataVersionKey -> Bool
$c> :: ChainDataVersionKey -> ChainDataVersionKey -> Bool
<= :: ChainDataVersionKey -> ChainDataVersionKey -> Bool
$c<= :: ChainDataVersionKey -> ChainDataVersionKey -> Bool
< :: ChainDataVersionKey -> ChainDataVersionKey -> Bool
$c< :: ChainDataVersionKey -> ChainDataVersionKey -> Bool
compare :: ChainDataVersionKey -> ChainDataVersionKey -> Ordering
$ccompare :: ChainDataVersionKey -> ChainDataVersionKey -> Ordering
Ord, Int -> ChainDataVersionKey -> ShowS
[ChainDataVersionKey] -> ShowS
ChainDataVersionKey -> String
(Int -> ChainDataVersionKey -> ShowS)
-> (ChainDataVersionKey -> String)
-> ([ChainDataVersionKey] -> ShowS)
-> Show ChainDataVersionKey
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ChainDataVersionKey] -> ShowS
$cshowList :: [ChainDataVersionKey] -> ShowS
show :: ChainDataVersionKey -> String
$cshow :: ChainDataVersionKey -> String
showsPrec :: Int -> ChainDataVersionKey -> ShowS
$cshowsPrec :: Int -> ChainDataVersionKey -> ShowS
Show)

instance Key ChainDataVersionKey
instance KeyValue ChainDataVersionKey Word32

instance Serialize ChainDataVersionKey where
    get :: Get ChainDataVersionKey
get = do
        Bool -> Get ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Get ()) -> (Word8 -> Bool) -> Word8 -> Get ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x92) (Word8 -> Get ()) -> Get Word8 -> Get ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Get Word8
getWord8
        ChainDataVersionKey -> Get ChainDataVersionKey
forall (m :: * -> *) a. Monad m => a -> m a
return ChainDataVersionKey
ChainDataVersionKey
    put :: Putter ChainDataVersionKey
put ChainDataVersionKey
ChainDataVersionKey = Putter Word8
putWord8 Word8
0x92

data ChainSync = ChainSync
    { ChainSync -> Peer
chainSyncPeer  :: !Peer
    , ChainSync -> UTCTime
chainTimestamp :: !UTCTime
    , ChainSync -> Maybe BlockNode
chainHighest   :: !(Maybe BlockNode)
    }

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

-- | Key for block header in database.
newtype BlockHeaderKey = BlockHeaderKey BlockHash deriving (BlockHeaderKey -> BlockHeaderKey -> Bool
(BlockHeaderKey -> BlockHeaderKey -> Bool)
-> (BlockHeaderKey -> BlockHeaderKey -> Bool) -> Eq BlockHeaderKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BlockHeaderKey -> BlockHeaderKey -> Bool
$c/= :: BlockHeaderKey -> BlockHeaderKey -> Bool
== :: BlockHeaderKey -> BlockHeaderKey -> Bool
$c== :: BlockHeaderKey -> BlockHeaderKey -> Bool
Eq, Int -> BlockHeaderKey -> ShowS
[BlockHeaderKey] -> ShowS
BlockHeaderKey -> String
(Int -> BlockHeaderKey -> ShowS)
-> (BlockHeaderKey -> String)
-> ([BlockHeaderKey] -> ShowS)
-> Show BlockHeaderKey
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BlockHeaderKey] -> ShowS
$cshowList :: [BlockHeaderKey] -> ShowS
show :: BlockHeaderKey -> String
$cshow :: BlockHeaderKey -> String
showsPrec :: Int -> BlockHeaderKey -> ShowS
$cshowsPrec :: Int -> BlockHeaderKey -> ShowS
Show)

instance Serialize BlockHeaderKey where
    get :: Get BlockHeaderKey
get = do
        Bool -> Get ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Get ()) -> (Word8 -> Bool) -> Word8 -> Get ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x90) (Word8 -> Get ()) -> Get Word8 -> Get ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Get Word8
getWord8
        BlockHash -> BlockHeaderKey
BlockHeaderKey (BlockHash -> BlockHeaderKey)
-> Get BlockHash -> Get BlockHeaderKey
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get BlockHash
forall t. Serialize t => Get t
get
    put :: Putter BlockHeaderKey
put (BlockHeaderKey BlockHash
bh) = do
        Putter Word8
putWord8 Word8
0x90
        Putter BlockHash
forall t. Serialize t => Putter t
put BlockHash
bh

-- | Key for best block in database.
data BestBlockKey = BestBlockKey deriving (BestBlockKey -> BestBlockKey -> Bool
(BestBlockKey -> BestBlockKey -> Bool)
-> (BestBlockKey -> BestBlockKey -> Bool) -> Eq BestBlockKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BestBlockKey -> BestBlockKey -> Bool
$c/= :: BestBlockKey -> BestBlockKey -> Bool
== :: BestBlockKey -> BestBlockKey -> Bool
$c== :: BestBlockKey -> BestBlockKey -> Bool
Eq, Int -> BestBlockKey -> ShowS
[BestBlockKey] -> ShowS
BestBlockKey -> String
(Int -> BestBlockKey -> ShowS)
-> (BestBlockKey -> String)
-> ([BestBlockKey] -> ShowS)
-> Show BestBlockKey
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BestBlockKey] -> ShowS
$cshowList :: [BestBlockKey] -> ShowS
show :: BestBlockKey -> String
$cshow :: BestBlockKey -> String
showsPrec :: Int -> BestBlockKey -> ShowS
$cshowsPrec :: Int -> BestBlockKey -> ShowS
Show)

instance KeyValue BlockHeaderKey BlockNode
instance KeyValue BestBlockKey BlockNode

instance Serialize BestBlockKey where
    get :: Get BestBlockKey
get = do
        Bool -> Get ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Get ()) -> (Word8 -> Bool) -> Word8 -> Get ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x91) (Word8 -> Get ()) -> Get Word8 -> Get ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Get Word8
getWord8
        BestBlockKey -> Get BestBlockKey
forall (m :: * -> *) a. Monad m => a -> m a
return BestBlockKey
BestBlockKey
    put :: Putter BestBlockKey
put BestBlockKey
BestBlockKey = Putter Word8
putWord8 Word8
0x91

instance MonadIO m => BlockHeaders (ReaderT ChainConfig m) where
    addBlockHeader :: BlockNode -> ReaderT ChainConfig m ()
addBlockHeader BlockNode
bn = do
        DB
db <- (ChainConfig -> DB) -> ReaderT ChainConfig m DB
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChainConfig -> DB
chainConfDB
        (ChainConfig -> Maybe ColumnFamily)
-> ReaderT ChainConfig m (Maybe ColumnFamily)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChainConfig -> Maybe ColumnFamily
chainConfColumnFamily ReaderT ChainConfig m (Maybe ColumnFamily)
-> (Maybe ColumnFamily -> ReaderT ChainConfig m ())
-> ReaderT ChainConfig m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Maybe ColumnFamily
Nothing -> DB -> BlockHeaderKey -> BlockNode -> ReaderT ChainConfig m ()
forall (m :: * -> *) key value.
(MonadIO m, KeyValue key value, Serialize key, Serialize value) =>
DB -> key -> value -> m ()
insert DB
db (BlockHash -> BlockHeaderKey
BlockHeaderKey BlockHash
h) BlockNode
bn
            Just ColumnFamily
cf -> DB
-> ColumnFamily
-> BlockHeaderKey
-> BlockNode
-> ReaderT ChainConfig m ()
forall (m :: * -> *) key value.
(MonadIO m, KeyValue key value, Serialize key, Serialize value) =>
DB -> ColumnFamily -> key -> value -> m ()
insertCF DB
db ColumnFamily
cf (BlockHash -> BlockHeaderKey
BlockHeaderKey BlockHash
h) BlockNode
bn
      where
        h :: BlockHash
h = BlockHeader -> BlockHash
headerHash (BlockNode -> BlockHeader
nodeHeader BlockNode
bn)
    getBlockHeader :: BlockHash -> ReaderT ChainConfig m (Maybe BlockNode)
getBlockHeader BlockHash
bh = do
        DB
db <- (ChainConfig -> DB) -> ReaderT ChainConfig m DB
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChainConfig -> DB
chainConfDB
        Maybe ColumnFamily
mcf <- (ChainConfig -> Maybe ColumnFamily)
-> ReaderT ChainConfig m (Maybe ColumnFamily)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChainConfig -> Maybe ColumnFamily
chainConfColumnFamily
        DB
-> Maybe ColumnFamily
-> BlockHeaderKey
-> ReaderT ChainConfig m (Maybe BlockNode)
forall (m :: * -> *) key value.
(MonadIO m, KeyValue key value, Serialize key, Serialize value) =>
DB -> Maybe ColumnFamily -> key -> m (Maybe value)
retrieveCommon DB
db Maybe ColumnFamily
mcf (BlockHash -> BlockHeaderKey
BlockHeaderKey BlockHash
bh)
    getBestBlockHeader :: ReaderT ChainConfig m BlockNode
getBestBlockHeader = do
        DB
db <- (ChainConfig -> DB) -> ReaderT ChainConfig m DB
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChainConfig -> DB
chainConfDB
        Maybe ColumnFamily
mcf <- (ChainConfig -> Maybe ColumnFamily)
-> ReaderT ChainConfig m (Maybe ColumnFamily)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChainConfig -> Maybe ColumnFamily
chainConfColumnFamily
        DB
-> Maybe ColumnFamily
-> BestBlockKey
-> ReaderT ChainConfig m (Maybe BlockNode)
forall (m :: * -> *) key value.
(MonadIO m, KeyValue key value, Serialize key, Serialize value) =>
DB -> Maybe ColumnFamily -> key -> m (Maybe value)
retrieveCommon DB
db Maybe ColumnFamily
mcf BestBlockKey
BestBlockKey ReaderT ChainConfig m (Maybe BlockNode)
-> (Maybe BlockNode -> ReaderT ChainConfig m BlockNode)
-> ReaderT ChainConfig m BlockNode
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Maybe BlockNode
Nothing -> String -> ReaderT ChainConfig m BlockNode
forall a. HasCallStack => String -> a
error String
"Could not get best block from database"
            Just BlockNode
b -> BlockNode -> ReaderT ChainConfig m BlockNode
forall (m :: * -> *) a. Monad m => a -> m a
return BlockNode
b
    setBestBlockHeader :: BlockNode -> ReaderT ChainConfig m ()
setBestBlockHeader BlockNode
bn = do
        DB
db <- (ChainConfig -> DB) -> ReaderT ChainConfig m DB
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChainConfig -> DB
chainConfDB
        (ChainConfig -> Maybe ColumnFamily)
-> ReaderT ChainConfig m (Maybe ColumnFamily)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChainConfig -> Maybe ColumnFamily
chainConfColumnFamily ReaderT ChainConfig m (Maybe ColumnFamily)
-> (Maybe ColumnFamily -> ReaderT ChainConfig m ())
-> ReaderT ChainConfig m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Maybe ColumnFamily
Nothing -> DB -> BestBlockKey -> BlockNode -> ReaderT ChainConfig m ()
forall (m :: * -> *) key value.
(MonadIO m, KeyValue key value, Serialize key, Serialize value) =>
DB -> key -> value -> m ()
insert DB
db BestBlockKey
BestBlockKey BlockNode
bn
            Just ColumnFamily
cf -> DB
-> ColumnFamily
-> BestBlockKey
-> BlockNode
-> ReaderT ChainConfig m ()
forall (m :: * -> *) key value.
(MonadIO m, KeyValue key value, Serialize key, Serialize value) =>
DB -> ColumnFamily -> key -> value -> m ()
insertCF DB
db ColumnFamily
cf BestBlockKey
BestBlockKey BlockNode
bn
    addBlockHeaders :: [BlockNode] -> ReaderT ChainConfig m ()
addBlockHeaders [BlockNode]
bns = do
        DB
db <- (ChainConfig -> DB) -> ReaderT ChainConfig m DB
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChainConfig -> DB
chainConfDB
        Maybe ColumnFamily
mcf <- (ChainConfig -> Maybe ColumnFamily)
-> ReaderT ChainConfig m (Maybe ColumnFamily)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChainConfig -> Maybe ColumnFamily
chainConfColumnFamily
        DB -> [BatchOp] -> ReaderT ChainConfig m ()
forall (m :: * -> *). MonadIO m => DB -> [BatchOp] -> m ()
writeBatch DB
db ((BlockNode -> BatchOp) -> [BlockNode] -> [BatchOp]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe ColumnFamily -> BlockNode -> BatchOp
f Maybe ColumnFamily
mcf) [BlockNode]
bns)
      where
        h :: BlockNode -> BlockHash
h BlockNode
bn = BlockHeader -> BlockHash
headerHash (BlockNode -> BlockHeader
nodeHeader BlockNode
bn)
        f :: Maybe ColumnFamily -> BlockNode -> BatchOp
f Maybe ColumnFamily
Nothing BlockNode
bn   = BlockHeaderKey -> BlockNode -> BatchOp
forall key value.
(KeyValue key value, Serialize key, Serialize value) =>
key -> value -> BatchOp
insertOp (BlockHash -> BlockHeaderKey
BlockHeaderKey (BlockNode -> BlockHash
h BlockNode
bn)) BlockNode
bn
        f (Just ColumnFamily
cf) BlockNode
bn = ColumnFamily -> BlockHeaderKey -> BlockNode -> BatchOp
forall key value.
(KeyValue key value, Serialize key, Serialize value) =>
ColumnFamily -> key -> value -> BatchOp
insertOpCF ColumnFamily
cf (BlockHash -> BlockHeaderKey
BlockHeaderKey (BlockNode -> BlockHash
h BlockNode
bn)) BlockNode
bn

instance MonadIO m => BlockHeaders (ReaderT Chain m) where
    getBlockHeader :: BlockHash -> ReaderT Chain m (Maybe BlockNode)
getBlockHeader BlockHash
bh = (Chain -> m (Maybe BlockNode)) -> ReaderT Chain m (Maybe BlockNode)
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((Chain -> m (Maybe BlockNode))
 -> ReaderT Chain m (Maybe BlockNode))
-> (Chain -> m (Maybe BlockNode))
-> ReaderT Chain m (Maybe BlockNode)
forall a b. (a -> b) -> a -> b
$ BlockHash -> Chain -> m (Maybe BlockNode)
forall (m :: * -> *).
MonadIO m =>
BlockHash -> Chain -> m (Maybe BlockNode)
chainGetBlock BlockHash
bh
    getBestBlockHeader :: ReaderT Chain m BlockNode
getBestBlockHeader = (Chain -> m BlockNode) -> ReaderT Chain m BlockNode
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT Chain -> m BlockNode
forall (m :: * -> *). MonadIO m => Chain -> m BlockNode
chainGetBest
    addBlockHeader :: BlockNode -> ReaderT Chain m ()
addBlockHeader BlockNode
_ = ReaderT Chain m ()
forall a. HasCallStack => a
undefined
    setBestBlockHeader :: BlockNode -> ReaderT Chain m ()
setBestBlockHeader BlockNode
_ = ReaderT Chain m ()
forall a. HasCallStack => a
undefined
    addBlockHeaders :: [BlockNode] -> ReaderT Chain m ()
addBlockHeaders [BlockNode]
_ = ReaderT Chain m ()
forall a. HasCallStack => a
undefined

withBlockHeaders :: MonadChain m => ReaderT ChainConfig m a -> m a
withBlockHeaders :: forall (m :: * -> *) a.
MonadChain m =>
ReaderT ChainConfig m a -> m a
withBlockHeaders ReaderT ChainConfig m a
f = do
    ChainConfig
cfg <- (ChainReader -> ChainConfig) -> m ChainConfig
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChainReader -> ChainConfig
myConfig
    ReaderT ChainConfig m a -> ChainConfig -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT ChainConfig m a
f ChainConfig
cfg

withChain ::
       (MonadUnliftIO m, MonadLoggerIO m)
    => ChainConfig
    -> (Chain -> m a)
    -> m a
withChain :: forall (m :: * -> *) a.
(MonadUnliftIO m, MonadLoggerIO m) =>
ChainConfig -> (Chain -> m a) -> m a
withChain ChainConfig
cfg Chain -> m a
action = do
    (Inbox ChainMessage
inbox, Mailbox ChainMessage
mailbox) <- m (Inbox ChainMessage, Mailbox ChainMessage)
forall (m :: * -> *) msg.
MonadUnliftIO m =>
m (Inbox msg, Mailbox msg)
newMailbox
    $(logDebugS) Text
"Chain" Text
"Starting chain actor"
    TVar ChainState
st <- ChainState -> m (TVar ChainState)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO ChainState :: Maybe ChainSync -> [Peer] -> Bool -> ChainState
ChainState { chainSyncing :: Maybe ChainSync
chainSyncing = Maybe ChainSync
forall a. Maybe a
Nothing
                               , mySynced :: Bool
mySynced = Bool
False
                               , newPeers :: [Peer]
newPeers = []
                               }
    let rd :: ChainReader
rd = ChainReader :: ChainConfig -> TVar ChainState -> ChainReader
ChainReader { myConfig :: ChainConfig
myConfig = ChainConfig
cfg
                         , chainState :: TVar ChainState
chainState = TVar ChainState
st
                         }
        ch :: Chain
ch = Chain :: Mailbox ChainMessage -> ChainReader -> Chain
Chain { chainReader :: ChainReader
chainReader = ChainReader
rd
                   , chainMailbox :: Mailbox ChainMessage
chainMailbox = Mailbox ChainMessage
mailbox
                   }
    ReaderT ChainReader m () -> ChainReader -> m ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT ChainReader m ()
forall (m :: * -> *). MonadChain m => m ()
initChainDB ChainReader
rd
    m Any -> (Async Any -> m a) -> m a
forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> (Async a -> m b) -> m b
withAsync (Chain -> ChainReader -> Inbox ChainMessage -> m Any
forall {m :: * -> *} {mbox :: * -> *} {a}.
(MonadLoggerIO m, MonadUnliftIO m, InChan mbox) =>
Chain -> ChainReader -> mbox ChainMessage -> m a
main_loop Chain
ch ChainReader
rd Inbox ChainMessage
inbox) ((Async Any -> m a) -> m a) -> (Async Any -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \Async Any
a ->
        Async Any -> m ()
forall (m :: * -> *) a. MonadIO m => Async a -> m ()
link Async Any
a m () -> m a -> m a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Chain -> m a
action Chain
ch
  where
    main_loop :: Chain -> ChainReader -> mbox ChainMessage -> m a
main_loop Chain
ch ChainReader
rd mbox ChainMessage
inbox = Chain -> m a -> m a
forall (m :: * -> *) a.
(MonadUnliftIO m, MonadLoggerIO m) =>
Chain -> m a -> m a
withSyncLoop Chain
ch (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$
        ReaderT ChainReader m a -> ChainReader -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (mbox ChainMessage -> ReaderT ChainReader m a
forall {m :: * -> *} {mbox :: * -> *} {b}.
(MonadLoggerIO m, MonadUnliftIO m, MonadReader ChainReader m,
 InChan mbox) =>
mbox ChainMessage -> m b
run mbox ChainMessage
inbox) ChainReader
rd
    run :: mbox ChainMessage -> m b
run mbox ChainMessage
inbox = do
        ReaderT ChainConfig m BlockNode -> m BlockNode
forall (m :: * -> *) a.
MonadChain m =>
ReaderT ChainConfig m a -> m a
withBlockHeaders ReaderT ChainConfig m BlockNode
forall (m :: * -> *). BlockHeaders m => m BlockNode
getBestBlockHeader m BlockNode -> (BlockNode -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
            ChainEvent -> m ()
forall (m :: * -> *). MonadChain m => ChainEvent -> m ()
chainEvent (ChainEvent -> m ())
-> (BlockNode -> ChainEvent) -> BlockNode -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockNode -> ChainEvent
ChainBestBlock
        m () -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (m () -> m b) -> m () -> m b
forall a b. (a -> b) -> a -> b
$ do
            ChainMessage
msg <- mbox ChainMessage -> m ChainMessage
forall (mbox :: * -> *) (m :: * -> *) msg.
(InChan mbox, MonadIO m) =>
mbox msg -> m msg
receive mbox ChainMessage
inbox
            ChainMessage -> m ()
forall (m :: * -> *). MonadChain m => ChainMessage -> m ()
chainMessage ChainMessage
msg

chainEvent :: MonadChain m => ChainEvent -> m ()
chainEvent :: forall (m :: * -> *). MonadChain m => ChainEvent -> m ()
chainEvent ChainEvent
e = do
    Publisher ChainEvent
pub <- (ChainReader -> Publisher ChainEvent) -> m (Publisher ChainEvent)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ChainConfig -> Publisher ChainEvent
chainConfEvents (ChainConfig -> Publisher ChainEvent)
-> (ChainReader -> ChainConfig)
-> ChainReader
-> Publisher ChainEvent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainReader -> ChainConfig
myConfig)
    case ChainEvent
e of
        ChainBestBlock BlockNode
b ->
            $(logInfoS) Text
"Chain" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
            Text
"Best block header at height: "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (Word32 -> String
forall a. Show a => a -> String
show (BlockNode -> Word32
nodeHeight BlockNode
b))
        ChainSynced BlockNode
b ->
            $(logInfoS) Text
"Chain" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
            Text
"Headers in sync at height: "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (Word32 -> String
forall a. Show a => a -> String
show (BlockNode -> Word32
nodeHeight BlockNode
b))
    ChainEvent -> Publisher ChainEvent -> m ()
forall (m :: * -> *) msg. MonadIO m => msg -> Publisher msg -> m ()
publish ChainEvent
e Publisher ChainEvent
pub

processHeaders :: MonadChain m => Peer -> [BlockHeader] -> m ()
processHeaders :: forall (m :: * -> *). MonadChain m => Peer -> [BlockHeader] -> m ()
processHeaders Peer
p [BlockHeader]
hs = do
    $(logDebugS) Text
"Chain" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
        Text
"Processing " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (Int -> String
forall a. Show a => a -> String
show ([BlockHeader] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BlockHeader]
hs))
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" headers from peer: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
    Network
net <- (ChainReader -> Network) -> m Network
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ChainConfig -> Network
chainConfNetwork (ChainConfig -> Network)
-> (ChainReader -> ChainConfig) -> ChainReader -> Network
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainReader -> ChainConfig
myConfig)
    UTCTime
now <- IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
    BlockNode
pbest <- ReaderT ChainConfig m BlockNode -> m BlockNode
forall (m :: * -> *) a.
MonadChain m =>
ReaderT ChainConfig m a -> m a
withBlockHeaders ReaderT ChainConfig m BlockNode
forall (m :: * -> *). BlockHeaders m => m BlockNode
getBestBlockHeader
    Network
-> UTCTime -> [BlockHeader] -> m (Either PeerException Bool)
forall (m :: * -> *).
MonadChain m =>
Network
-> UTCTime -> [BlockHeader] -> m (Either PeerException Bool)
importHeaders Network
net UTCTime
now [BlockHeader]
hs m (Either PeerException Bool)
-> (Either PeerException Bool -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left PeerException
e -> do
            $(logErrorS) Text
"Chain" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
                Text
"Could not connect headers from peer: "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
            PeerException
e PeerException -> Peer -> m ()
forall (m :: * -> *). MonadIO m => PeerException -> Peer -> m ()
`killPeer` Peer
p
        Right Bool
done -> do
            m ()
forall (m :: * -> *). MonadChain m => m ()
setLastReceived
            BlockNode
best <- ReaderT ChainConfig m BlockNode -> m BlockNode
forall (m :: * -> *) a.
MonadChain m =>
ReaderT ChainConfig m a -> m a
withBlockHeaders ReaderT ChainConfig m BlockNode
forall (m :: * -> *). BlockHeaders m => m BlockNode
getBestBlockHeader
            Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BlockNode -> BlockHeader
nodeHeader BlockNode
pbest BlockHeader -> BlockHeader -> Bool
forall a. Eq a => a -> a -> Bool
/= BlockNode -> BlockHeader
nodeHeader BlockNode
best) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
                ChainEvent -> m ()
forall (m :: * -> *). MonadChain m => ChainEvent -> m ()
chainEvent (BlockNode -> ChainEvent
ChainBestBlock BlockNode
best)
            if Bool
done
                then do
                    Message
MSendHeaders Message -> Peer -> m ()
forall (m :: * -> *). MonadIO m => Message -> Peer -> m ()
`sendMessage` Peer
p
                    Peer -> m ()
forall (m :: * -> *). MonadChain m => Peer -> m ()
finishPeer Peer
p
                    m ()
forall (m :: * -> *). MonadChain m => m ()
syncNewPeer
                    m ()
forall (m :: * -> *). MonadChain m => m ()
syncNotif
                else Peer -> m ()
forall (m :: * -> *). MonadChain m => Peer -> m ()
syncPeer Peer
p

syncNewPeer :: MonadChain m => m ()
syncNewPeer :: forall (m :: * -> *). MonadChain m => m ()
syncNewPeer = m (Maybe Peer)
forall (m :: * -> *). MonadChain m => m (Maybe Peer)
getSyncingPeer m (Maybe Peer) -> (Maybe Peer -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just Peer
_  -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Maybe Peer
Nothing -> m (Maybe Peer)
forall (m :: * -> *). MonadChain m => m (Maybe Peer)
nextPeer m (Maybe Peer) -> (Maybe Peer -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe Peer
Nothing -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just Peer
p -> do
            $(logDebugS) Text
"Chain" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
                Text
"Syncing against peer: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
            Peer -> m ()
forall (m :: * -> *). MonadChain m => Peer -> m ()
syncPeer Peer
p

syncNotif :: MonadChain m => m ()
syncNotif :: forall (m :: * -> *). MonadChain m => m ()
syncNotif =
    m Bool
forall (m :: * -> *). MonadChain m => m Bool
notifySynced m Bool -> (Bool -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Bool
False -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Bool
True  -> ReaderT ChainConfig m BlockNode -> m BlockNode
forall (m :: * -> *) a.
MonadChain m =>
ReaderT ChainConfig m a -> m a
withBlockHeaders ReaderT ChainConfig m BlockNode
forall (m :: * -> *). BlockHeaders m => m BlockNode
getBestBlockHeader m BlockNode -> (BlockNode -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                 ChainEvent -> m ()
forall (m :: * -> *). MonadChain m => ChainEvent -> m ()
chainEvent (ChainEvent -> m ())
-> (BlockNode -> ChainEvent) -> BlockNode -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockNode -> ChainEvent
ChainSynced

syncPeer :: MonadChain m => Peer -> m ()
syncPeer :: forall (m :: * -> *). MonadChain m => Peer -> m ()
syncPeer Peer
p = do
    UTCTime
t <- IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
    Maybe GetHeaders
m <- m (Maybe ChainSync)
forall (m :: * -> *). MonadChain m => m (Maybe ChainSync)
chainSyncingPeer m (Maybe ChainSync)
-> (Maybe ChainSync -> m (Maybe GetHeaders))
-> m (Maybe GetHeaders)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just ChainSync { chainSyncPeer :: ChainSync -> Peer
chainSyncPeer = Peer
s
                       , chainHighest :: ChainSync -> Maybe BlockNode
chainHighest = Maybe BlockNode
m
                       }
            | Peer
p Peer -> Peer -> Bool
forall a. Eq a => a -> a -> Bool
== Peer
s -> UTCTime -> Maybe BlockNode -> m (Maybe GetHeaders)
forall {m :: * -> *}.
(MonadLoggerIO m, MonadUnliftIO m, MonadReader ChainReader m) =>
UTCTime -> Maybe BlockNode -> m (Maybe GetHeaders)
syncing_me UTCTime
t Maybe BlockNode
m
            | Bool
otherwise -> Maybe GetHeaders -> m (Maybe GetHeaders)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe GetHeaders
forall a. Maybe a
Nothing
        Maybe ChainSync
Nothing -> UTCTime -> m (Maybe GetHeaders)
forall {m :: * -> *}.
(MonadLoggerIO m, MonadUnliftIO m, MonadReader ChainReader m) =>
UTCTime -> m (Maybe GetHeaders)
syncing_new UTCTime
t
    Maybe GetHeaders -> (GetHeaders -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe GetHeaders
m ((GetHeaders -> m ()) -> m ()) -> (GetHeaders -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \GetHeaders
g -> do
        $(logDebugS) Text
"Chain" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
            Text
"Requesting headers from peer: "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
        GetHeaders -> Message
MGetHeaders GetHeaders
g Message -> Peer -> m ()
forall (m :: * -> *). MonadIO m => Message -> Peer -> m ()
`sendMessage` Peer
p
  where
    syncing_new :: UTCTime -> m (Maybe GetHeaders)
syncing_new UTCTime
t =
        Peer -> m Bool
forall (m :: * -> *). MonadChain m => Peer -> m Bool
setSyncingPeer Peer
p m Bool -> (Bool -> m (Maybe GetHeaders)) -> m (Maybe GetHeaders)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Bool
False -> Maybe GetHeaders -> m (Maybe GetHeaders)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe GetHeaders
forall a. Maybe a
Nothing
            Bool
True -> do
                $(logDebugS) Text
"Chain" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
                    Text
"Locked peer: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
                BlockNode
h <- ReaderT ChainConfig m BlockNode -> m BlockNode
forall (m :: * -> *) a.
MonadChain m =>
ReaderT ChainConfig m a -> m a
withBlockHeaders ReaderT ChainConfig m BlockNode
forall (m :: * -> *). BlockHeaders m => m BlockNode
getBestBlockHeader
                GetHeaders -> Maybe GetHeaders
forall a. a -> Maybe a
Just (GetHeaders -> Maybe GetHeaders)
-> m GetHeaders -> m (Maybe GetHeaders)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTCTime -> BlockNode -> Peer -> m GetHeaders
forall (m :: * -> *).
MonadChain m =>
UTCTime -> BlockNode -> Peer -> m GetHeaders
syncHeaders UTCTime
t BlockNode
h Peer
p
    syncing_me :: UTCTime -> Maybe BlockNode -> m (Maybe GetHeaders)
syncing_me UTCTime
t Maybe BlockNode
m = do
        BlockNode
h <- case Maybe BlockNode
m of
                 Maybe BlockNode
Nothing -> ReaderT ChainConfig m BlockNode -> m BlockNode
forall (m :: * -> *) a.
MonadChain m =>
ReaderT ChainConfig m a -> m a
withBlockHeaders ReaderT ChainConfig m BlockNode
forall (m :: * -> *). BlockHeaders m => m BlockNode
getBestBlockHeader
                 Just BlockNode
h  -> BlockNode -> m BlockNode
forall (m :: * -> *) a. Monad m => a -> m a
return BlockNode
h
        GetHeaders -> Maybe GetHeaders
forall a. a -> Maybe a
Just (GetHeaders -> Maybe GetHeaders)
-> m GetHeaders -> m (Maybe GetHeaders)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTCTime -> BlockNode -> Peer -> m GetHeaders
forall (m :: * -> *).
MonadChain m =>
UTCTime -> BlockNode -> Peer -> m GetHeaders
syncHeaders UTCTime
t BlockNode
h Peer
p

chainMessage :: MonadChain m => ChainMessage -> m ()

chainMessage :: forall (m :: * -> *). MonadChain m => ChainMessage -> m ()
chainMessage (ChainHeaders Peer
p [BlockHeader]
hs) =
    Peer -> [BlockHeader] -> m ()
forall (m :: * -> *). MonadChain m => Peer -> [BlockHeader] -> m ()
processHeaders Peer
p [BlockHeader]
hs

chainMessage (ChainPeerConnected Peer
p) = do
    $(logDebugS) Text
"Chain" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Peer connected: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
    Peer -> m ()
forall (m :: * -> *). MonadChain m => Peer -> m ()
addPeer Peer
p
    m ()
forall (m :: * -> *). MonadChain m => m ()
syncNewPeer

chainMessage (ChainPeerDisconnected Peer
p) = do
    $(logDebugS) Text
"Chain" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Peer disconnected: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
    Peer -> m ()
forall (m :: * -> *). MonadChain m => Peer -> m ()
finishPeer Peer
p
    m ()
forall (m :: * -> *). MonadChain m => m ()
syncNewPeer

chainMessage ChainMessage
ChainPing = do
    NominalDiffTime
to <- (ChainReader -> NominalDiffTime) -> m NominalDiffTime
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ChainConfig -> NominalDiffTime
chainConfTimeout (ChainConfig -> NominalDiffTime)
-> (ChainReader -> ChainConfig) -> ChainReader -> NominalDiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainReader -> ChainConfig
myConfig)
    UTCTime
now <- IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
    m (Maybe ChainSync)
forall (m :: * -> *). MonadChain m => m (Maybe ChainSync)
chainSyncingPeer m (Maybe ChainSync) -> (Maybe ChainSync -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just ChainSync {chainSyncPeer :: ChainSync -> Peer
chainSyncPeer = Peer
p, chainTimestamp :: ChainSync -> UTCTime
chainTimestamp = UTCTime
t}
            | UTCTime
now UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` UTCTime
t NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
> NominalDiffTime
to -> do
                $(logErrorS) Text
"Chain" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
                    Text
"Syncing peer timed out: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
                PeerException
PeerTimeout PeerException -> Peer -> m ()
forall (m :: * -> *). MonadIO m => PeerException -> Peer -> m ()
`killPeer` Peer
p
            | Bool
otherwise -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Maybe ChainSync
Nothing -> m ()
forall (m :: * -> *). MonadChain m => m ()
syncNewPeer

withSyncLoop :: (MonadUnliftIO m, MonadLoggerIO m)
             => Chain -> m a -> m a
withSyncLoop :: forall (m :: * -> *) a.
(MonadUnliftIO m, MonadLoggerIO m) =>
Chain -> m a -> m a
withSyncLoop Chain
ch m a
f =
    m Any -> (Async Any -> m a) -> m a
forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> (Async a -> m b) -> m b
withAsync m Any
forall {b}. m b
go ((Async Any -> m a) -> m a) -> (Async Any -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \Async Any
a ->
    Async Any -> m ()
forall (m :: * -> *) a. MonadIO m => Async a -> m ()
link Async Any
a m () -> m a -> m a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m a
f
  where
    go :: m b
go = m () -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (m () -> m b) -> m () -> m b
forall a b. (a -> b) -> a -> b
$ do
        Int
delay <- IO Int -> m Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> m Int) -> IO Int -> m Int
forall a b. (a -> b) -> a -> b
$
            CharPos -> IO Int
forall a (m :: * -> *). (Random a, MonadIO m) => (a, a) -> m a
randomRIO (  Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000
                      , Int
20 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000 )
        Int -> m ()
forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay Int
delay
        ChainMessage
ChainPing ChainMessage -> Mailbox ChainMessage -> m ()
forall (m :: * -> *) (mbox :: * -> *) msg.
(MonadIO m, OutChan mbox) =>
msg -> mbox msg -> m ()
`send` Chain -> Mailbox ChainMessage
chainMailbox Chain
ch

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

-- | Initialize header database. If version is different from current, the
-- database is purged of conflicting elements first.
initChainDB :: MonadChain m => m ()
initChainDB :: forall (m :: * -> *). MonadChain m => m ()
initChainDB = do
    DB
db <- (ChainReader -> DB) -> m DB
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ChainConfig -> DB
chainConfDB (ChainConfig -> DB)
-> (ChainReader -> ChainConfig) -> ChainReader -> DB
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainReader -> ChainConfig
myConfig)
    Maybe ColumnFamily
mcf <- (ChainReader -> Maybe ColumnFamily) -> m (Maybe ColumnFamily)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ChainConfig -> Maybe ColumnFamily
chainConfColumnFamily (ChainConfig -> Maybe ColumnFamily)
-> (ChainReader -> ChainConfig)
-> ChainReader
-> Maybe ColumnFamily
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainReader -> ChainConfig
myConfig)
    Network
net <- (ChainReader -> Network) -> m Network
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ChainConfig -> Network
chainConfNetwork (ChainConfig -> Network)
-> (ChainReader -> ChainConfig) -> ChainReader -> Network
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainReader -> ChainConfig
myConfig)
    Maybe Word32
ver <- DB -> Maybe ColumnFamily -> ChainDataVersionKey -> m (Maybe Word32)
forall (m :: * -> *) key value.
(MonadIO m, KeyValue key value, Serialize key, Serialize value) =>
DB -> Maybe ColumnFamily -> key -> m (Maybe value)
retrieveCommon DB
db Maybe ColumnFamily
mcf ChainDataVersionKey
ChainDataVersionKey
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Word32
ver Maybe Word32 -> Maybe Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word32 -> Maybe Word32
forall a. a -> Maybe a
Just Word32
dataVersion) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ m [BatchOp]
forall (m :: * -> *). MonadChain m => m [BatchOp]
purgeChainDB m [BatchOp] -> ([BatchOp] -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= DB -> [BatchOp] -> m ()
forall (m :: * -> *). MonadIO m => DB -> [BatchOp] -> m ()
writeBatch DB
db
    case Maybe ColumnFamily
mcf of
        Maybe ColumnFamily
Nothing -> DB -> ChainDataVersionKey -> Word32 -> m ()
forall (m :: * -> *) key value.
(MonadIO m, KeyValue key value, Serialize key, Serialize value) =>
DB -> key -> value -> m ()
insert DB
db ChainDataVersionKey
ChainDataVersionKey Word32
dataVersion
        Just ColumnFamily
cf -> DB -> ColumnFamily -> ChainDataVersionKey -> Word32 -> m ()
forall (m :: * -> *) key value.
(MonadIO m, KeyValue key value, Serialize key, Serialize value) =>
DB -> ColumnFamily -> key -> value -> m ()
insertCF DB
db ColumnFamily
cf ChainDataVersionKey
ChainDataVersionKey Word32
dataVersion
    DB -> Maybe ColumnFamily -> BestBlockKey -> m (Maybe BlockNode)
forall (m :: * -> *) key value.
(MonadIO m, KeyValue key value, Serialize key, Serialize value) =>
DB -> Maybe ColumnFamily -> key -> m (Maybe value)
retrieveCommon DB
db Maybe ColumnFamily
mcf BestBlockKey
BestBlockKey m (Maybe BlockNode) -> (Maybe BlockNode -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Maybe BlockNode
b ->
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe BlockNode -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe BlockNode
b :: Maybe BlockNode)) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
        ReaderT ChainConfig m () -> m ()
forall (m :: * -> *) a.
MonadChain m =>
ReaderT ChainConfig m a -> m a
withBlockHeaders (ReaderT ChainConfig m () -> m ())
-> ReaderT ChainConfig m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
            BlockNode -> ReaderT ChainConfig m ()
forall (m :: * -> *). BlockHeaders m => BlockNode -> m ()
addBlockHeader (Network -> BlockNode
genesisNode Network
net)
            BlockNode -> ReaderT ChainConfig m ()
forall (m :: * -> *). BlockHeaders m => BlockNode -> m ()
setBestBlockHeader (Network -> BlockNode
genesisNode Network
net)

-- | Purge database of elements having keys that may conflict with those used in
-- this module.
purgeChainDB :: MonadChain m => m [R.BatchOp]
purgeChainDB :: forall (m :: * -> *). MonadChain m => m [BatchOp]
purgeChainDB = do
    DB
db <- (ChainReader -> DB) -> m DB
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ChainConfig -> DB
chainConfDB (ChainConfig -> DB)
-> (ChainReader -> ChainConfig) -> ChainReader -> DB
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainReader -> ChainConfig
myConfig)
    Maybe ColumnFamily
mcf <- (ChainReader -> Maybe ColumnFamily) -> m (Maybe ColumnFamily)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ChainConfig -> Maybe ColumnFamily
chainConfColumnFamily (ChainConfig -> Maybe ColumnFamily)
-> (ChainReader -> ChainConfig)
-> ChainReader
-> Maybe ColumnFamily
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainReader -> ChainConfig
myConfig)
    DB
-> Maybe ColumnFamily -> (Iterator -> m [BatchOp]) -> m [BatchOp]
forall {m :: * -> *} {a}.
MonadUnliftIO m =>
DB -> Maybe ColumnFamily -> (Iterator -> m a) -> m a
f DB
db Maybe ColumnFamily
mcf ((Iterator -> m [BatchOp]) -> m [BatchOp])
-> (Iterator -> m [BatchOp]) -> m [BatchOp]
forall a b. (a -> b) -> a -> b
$ \Iterator
it -> do
        Iterator -> ByteString -> m ()
forall (m :: * -> *). MonadIO m => Iterator -> ByteString -> m ()
R.iterSeek Iterator
it (ByteString -> m ()) -> ByteString -> m ()
forall a b. (a -> b) -> a -> b
$ Word8 -> ByteString
B.singleton Word8
0x90
        Iterator -> DB -> Maybe ColumnFamily -> m [BatchOp]
forall {m :: * -> *}.
MonadIO m =>
Iterator -> DB -> Maybe ColumnFamily -> m [BatchOp]
recurse_delete Iterator
it DB
db Maybe ColumnFamily
mcf
  where
    f :: DB -> Maybe ColumnFamily -> (Iterator -> m a) -> m a
f DB
db Maybe ColumnFamily
Nothing   = DB -> (Iterator -> m a) -> m a
forall (m :: * -> *) a.
MonadUnliftIO m =>
DB -> (Iterator -> m a) -> m a
R.withIter DB
db
    f DB
db (Just ColumnFamily
cf) = DB -> ColumnFamily -> (Iterator -> m a) -> m a
forall (m :: * -> *) a.
MonadUnliftIO m =>
DB -> ColumnFamily -> (Iterator -> m a) -> m a
R.withIterCF DB
db ColumnFamily
cf
    recurse_delete :: Iterator -> DB -> Maybe ColumnFamily -> m [BatchOp]
recurse_delete Iterator
it DB
db Maybe ColumnFamily
mcf =
        Iterator -> m (Maybe ByteString)
forall (m :: * -> *). MonadIO m => Iterator -> m (Maybe ByteString)
R.iterKey Iterator
it m (Maybe ByteString)
-> (Maybe ByteString -> m [BatchOp]) -> m [BatchOp]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just ByteString
k
                | ByteString -> Word8
B.head ByteString
k Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x90 Bool -> Bool -> Bool
|| ByteString -> Word8
B.head ByteString
k Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x91 -> do
                    case Maybe ColumnFamily
mcf of
                        Maybe ColumnFamily
Nothing -> DB -> ByteString -> m ()
forall (m :: * -> *). MonadIO m => DB -> ByteString -> m ()
R.delete DB
db ByteString
k
                        Just ColumnFamily
cf -> DB -> ColumnFamily -> ByteString -> m ()
forall (m :: * -> *).
MonadIO m =>
DB -> ColumnFamily -> ByteString -> m ()
R.deleteCF DB
db ColumnFamily
cf ByteString
k
                    Iterator -> m ()
forall (m :: * -> *). MonadIO m => Iterator -> m ()
R.iterNext Iterator
it
                    (ByteString -> BatchOp
R.Del ByteString
k BatchOp -> [BatchOp] -> [BatchOp]
forall a. a -> [a] -> [a]
:) ([BatchOp] -> [BatchOp]) -> m [BatchOp] -> m [BatchOp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Iterator -> DB -> Maybe ColumnFamily -> m [BatchOp]
recurse_delete Iterator
it DB
db Maybe ColumnFamily
mcf
            Maybe ByteString
_ -> [BatchOp] -> m [BatchOp]
forall (m :: * -> *) a. Monad m => a -> m a
return []

-- | Import a bunch of continuous headers. Returns 'True' if the number of
-- headers is 2000, which means that there are possibly more headers to sync
-- from whatever peer delivered these.
importHeaders :: MonadChain m
              => Network
              -> UTCTime
              -> [BlockHeader]
              -> m (Either PeerException Bool)
importHeaders :: forall (m :: * -> *).
MonadChain m =>
Network
-> UTCTime -> [BlockHeader] -> m (Either PeerException Bool)
importHeaders Network
net UTCTime
now [BlockHeader]
hs =
    ExceptT PeerException m Bool -> m (Either PeerException Bool)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT PeerException m Bool -> m (Either PeerException Bool))
-> ExceptT PeerException m Bool -> m (Either PeerException Bool)
forall a b. (a -> b) -> a -> b
$
    m (Either String [BlockNode])
-> ExceptT PeerException m (Either String [BlockNode])
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m (Either String [BlockNode])
connect ExceptT PeerException m (Either String [BlockNode])
-> (Either String [BlockNode] -> ExceptT PeerException m Bool)
-> ExceptT PeerException m Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Right [BlockNode]
_ -> do
            case [BlockHeader]
hs of
                [] -> () -> ExceptT PeerException m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                [BlockHeader]
_ -> do
                    Maybe BlockNode
bb <- m (Maybe BlockNode) -> ExceptT PeerException m (Maybe BlockNode)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m (Maybe BlockNode)
get_last
                    TVar ChainState
box <- (ChainReader -> TVar ChainState)
-> ExceptT PeerException m (TVar ChainState)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChainReader -> TVar ChainState
chainState
                    STM () -> ExceptT PeerException m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ExceptT PeerException m ())
-> ((ChainState -> ChainState) -> STM ())
-> (ChainState -> ChainState)
-> ExceptT PeerException m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar ChainState -> (ChainState -> ChainState) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar ChainState
box ((ChainState -> ChainState) -> ExceptT PeerException m ())
-> (ChainState -> ChainState) -> ExceptT PeerException m ()
forall a b. (a -> b) -> a -> b
$ \ChainState
s ->
                        ChainState
s { chainSyncing :: Maybe ChainSync
chainSyncing =
                            (\ChainSync
x -> ChainSync
x {chainHighest :: Maybe BlockNode
chainHighest = Maybe BlockNode
bb})
                            (ChainSync -> ChainSync) -> Maybe ChainSync -> Maybe ChainSync
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainState -> Maybe ChainSync
chainSyncing ChainState
s
                          }
            case [BlockHeader] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BlockHeader]
hs of
                Int
2000 -> Bool -> ExceptT PeerException m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                Int
_    -> Bool -> ExceptT PeerException m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        Left String
_ -> PeerException -> ExceptT PeerException m Bool
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError PeerException
PeerSentBadHeaders
  where
    timestamp :: Word32
timestamp = NominalDiffTime -> Word32
forall a b. (RealFrac a, Integral b) => a -> b
floor (UTCTime -> NominalDiffTime
utcTimeToPOSIXSeconds UTCTime
now)
    connect :: m (Either String [BlockNode])
connect = ReaderT ChainConfig m (Either String [BlockNode])
-> m (Either String [BlockNode])
forall (m :: * -> *) a.
MonadChain m =>
ReaderT ChainConfig m a -> m a
withBlockHeaders (ReaderT ChainConfig m (Either String [BlockNode])
 -> m (Either String [BlockNode]))
-> ReaderT ChainConfig m (Either String [BlockNode])
-> m (Either String [BlockNode])
forall a b. (a -> b) -> a -> b
$ Network
-> Word32
-> [BlockHeader]
-> ReaderT ChainConfig m (Either String [BlockNode])
forall (m :: * -> *).
BlockHeaders m =>
Network -> Word32 -> [BlockHeader] -> m (Either String [BlockNode])
connectBlocks Network
net Word32
timestamp [BlockHeader]
hs
    get_last :: m (Maybe BlockNode)
get_last = ReaderT ChainConfig m (Maybe BlockNode) -> m (Maybe BlockNode)
forall (m :: * -> *) a.
MonadChain m =>
ReaderT ChainConfig m a -> m a
withBlockHeaders (ReaderT ChainConfig m (Maybe BlockNode) -> m (Maybe BlockNode))
-> (BlockHeader -> ReaderT ChainConfig m (Maybe BlockNode))
-> BlockHeader
-> m (Maybe BlockNode)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockHash -> ReaderT ChainConfig m (Maybe BlockNode)
forall (m :: * -> *).
BlockHeaders m =>
BlockHash -> m (Maybe BlockNode)
getBlockHeader (BlockHash -> ReaderT ChainConfig m (Maybe BlockNode))
-> (BlockHeader -> BlockHash)
-> BlockHeader
-> ReaderT ChainConfig m (Maybe BlockNode)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockHeader -> BlockHash
headerHash (BlockHeader -> m (Maybe BlockNode))
-> BlockHeader -> m (Maybe BlockNode)
forall a b. (a -> b) -> a -> b
$ [BlockHeader] -> BlockHeader
forall a. [a] -> a
last [BlockHeader]
hs

-- | 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'.
notifySynced :: MonadChain m => m Bool
notifySynced :: forall (m :: * -> *). MonadChain m => m Bool
notifySynced =
    (Maybe () -> Bool) -> m (Maybe ()) -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe () -> Bool
forall a. Maybe a -> Bool
isJust (m (Maybe ()) -> m Bool) -> m (Maybe ()) -> m Bool
forall a b. (a -> b) -> a -> b
$
    MaybeT m () -> m (Maybe ())
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT m () -> m (Maybe ())) -> MaybeT m () -> m (Maybe ())
forall a b. (a -> b) -> a -> b
$ do
        BlockNode
bb <- m BlockNode -> MaybeT m BlockNode
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m BlockNode -> MaybeT m BlockNode)
-> m BlockNode -> MaybeT m BlockNode
forall a b. (a -> b) -> a -> b
$ ReaderT ChainConfig m BlockNode -> m BlockNode
forall (m :: * -> *) a.
MonadChain m =>
ReaderT ChainConfig m a -> m a
withBlockHeaders ReaderT ChainConfig m BlockNode
forall (m :: * -> *). BlockHeaders m => m BlockNode
getBestBlockHeader
        UTCTime
now <- IO UTCTime -> MaybeT m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
        Bool -> MaybeT m ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> MaybeT m ()) -> Bool -> MaybeT m ()
forall a b. (a -> b) -> a -> b
$ UTCTime
now UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` BlockNode -> UTCTime
block_time BlockNode
bb NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
> NominalDiffTime
7200
        TVar ChainState
st <- (ChainReader -> TVar ChainState) -> MaybeT m (TVar ChainState)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChainReader -> TVar ChainState
chainState
        m (Maybe ()) -> MaybeT m ()
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe ()) -> MaybeT m ())
-> (MaybeT STM () -> m (Maybe ())) -> MaybeT STM () -> MaybeT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM (Maybe ()) -> m (Maybe ())
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Maybe ()) -> m (Maybe ()))
-> (MaybeT STM () -> STM (Maybe ()))
-> MaybeT STM ()
-> m (Maybe ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MaybeT STM () -> STM (Maybe ())
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT STM () -> MaybeT m ()) -> MaybeT STM () -> MaybeT m ()
forall a b. (a -> b) -> a -> b
$ do
            ChainState
s <- STM ChainState -> MaybeT STM ChainState
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (STM ChainState -> MaybeT STM ChainState)
-> STM ChainState -> MaybeT STM ChainState
forall a b. (a -> b) -> a -> b
$ TVar ChainState -> STM ChainState
forall a. TVar a -> STM a
readTVar TVar ChainState
st
            Bool -> MaybeT STM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> MaybeT STM ())
-> (Maybe ChainSync -> Bool) -> Maybe ChainSync -> MaybeT STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe ChainSync -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe ChainSync -> MaybeT STM ())
-> Maybe ChainSync -> MaybeT STM ()
forall a b. (a -> b) -> a -> b
$ ChainState -> Maybe ChainSync
chainSyncing ChainState
s
            Bool -> MaybeT STM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> MaybeT STM ())
-> ([Peer] -> Bool) -> [Peer] -> MaybeT STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Peer] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Peer] -> MaybeT STM ()) -> [Peer] -> MaybeT STM ()
forall a b. (a -> b) -> a -> b
$ ChainState -> [Peer]
newPeers ChainState
s
            Bool -> MaybeT STM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> MaybeT STM ()) -> (Bool -> Bool) -> Bool -> MaybeT STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not (Bool -> MaybeT STM ()) -> Bool -> MaybeT STM ()
forall a b. (a -> b) -> a -> b
$ ChainState -> Bool
mySynced ChainState
s
            STM () -> MaybeT STM ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (STM () -> MaybeT STM ()) -> STM () -> MaybeT STM ()
forall a b. (a -> b) -> a -> b
$ TVar ChainState -> ChainState -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar ChainState
st ChainState
s {mySynced :: Bool
mySynced = Bool
True}
            () -> MaybeT STM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    block_time :: BlockNode -> UTCTime
block_time =
        NominalDiffTime -> UTCTime
posixSecondsToUTCTime (NominalDiffTime -> UTCTime)
-> (BlockNode -> NominalDiffTime) -> BlockNode -> UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> NominalDiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> NominalDiffTime)
-> (BlockNode -> Word32) -> BlockNode -> NominalDiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockHeader -> Word32
blockTimestamp (BlockHeader -> Word32)
-> (BlockNode -> BlockHeader) -> BlockNode -> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockNode -> BlockHeader
nodeHeader

-- | Get next peer to sync against from the queue.
nextPeer :: MonadChain m => m (Maybe Peer)
nextPeer :: forall (m :: * -> *). MonadChain m => m (Maybe Peer)
nextPeer = do
    [Peer]
ps <- ChainState -> [Peer]
newPeers (ChainState -> [Peer]) -> m ChainState -> m [Peer]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TVar ChainState -> m ChainState
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (TVar ChainState -> m ChainState)
-> m (TVar ChainState) -> m ChainState
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (ChainReader -> TVar ChainState) -> m (TVar ChainState)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChainReader -> TVar ChainState
chainState)
    [Peer] -> m (Maybe Peer)
forall {m :: * -> *}.
(MonadLoggerIO m, MonadUnliftIO m, MonadReader ChainReader m) =>
[Peer] -> m (Maybe Peer)
go [Peer]
ps
  where
    go :: [Peer] -> m (Maybe Peer)
go [] = Maybe Peer -> m (Maybe Peer)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Peer
forall a. Maybe a
Nothing
    go (Peer
p:[Peer]
ps) =
        Peer -> m Bool
forall (m :: * -> *). MonadChain m => Peer -> m Bool
setSyncingPeer Peer
p m Bool -> (Bool -> m (Maybe Peer)) -> m (Maybe Peer)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Bool
True -> Maybe Peer -> m (Maybe Peer)
forall (m :: * -> *) a. Monad m => a -> m a
return (Peer -> Maybe Peer
forall a. a -> Maybe a
Just Peer
p)
            Bool
False -> [Peer] -> m (Maybe Peer)
go [Peer]
ps

-- | Set a syncing peer and generate a 'GetHeaders' data structure with a block
-- locator to send to that peer for syncing.
syncHeaders ::
       MonadChain m
    => UTCTime
    -> BlockNode
    -> Peer
    -> m GetHeaders
syncHeaders :: forall (m :: * -> *).
MonadChain m =>
UTCTime -> BlockNode -> Peer -> m GetHeaders
syncHeaders UTCTime
now BlockNode
bb Peer
p = do
    TVar ChainState
st <- (ChainReader -> TVar ChainState) -> m (TVar ChainState)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChainReader -> TVar ChainState
chainState
    STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$
        TVar ChainState -> (ChainState -> ChainState) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar ChainState
st ((ChainState -> ChainState) -> STM ())
-> (ChainState -> ChainState) -> STM ()
forall a b. (a -> b) -> a -> b
$ \ChainState
s ->
            ChainState
s { chainSyncing :: Maybe ChainSync
chainSyncing =
                    ChainSync -> Maybe ChainSync
forall a. a -> Maybe a
Just
                        ChainSync :: Peer -> UTCTime -> Maybe BlockNode -> ChainSync
ChainSync
                            { chainSyncPeer :: Peer
chainSyncPeer = Peer
p
                            , chainTimestamp :: UTCTime
chainTimestamp = UTCTime
now
                            , chainHighest :: Maybe BlockNode
chainHighest = Maybe BlockNode
forall a. Maybe a
Nothing
                            }
              , newPeers :: [Peer]
newPeers = Peer -> [Peer] -> [Peer]
forall a. Eq a => a -> [a] -> [a]
delete Peer
p (ChainState -> [Peer]
newPeers ChainState
s)
              }
    BlockLocator
loc <- ReaderT ChainConfig m BlockLocator -> m BlockLocator
forall (m :: * -> *) a.
MonadChain m =>
ReaderT ChainConfig m a -> m a
withBlockHeaders (ReaderT ChainConfig m BlockLocator -> m BlockLocator)
-> ReaderT ChainConfig m BlockLocator -> m BlockLocator
forall a b. (a -> b) -> a -> b
$ BlockNode -> ReaderT ChainConfig m BlockLocator
forall (m :: * -> *). BlockHeaders m => BlockNode -> m BlockLocator
blockLocator BlockNode
bb
    GetHeaders -> m GetHeaders
forall (m :: * -> *) a. Monad m => a -> m a
return
        GetHeaders :: Word32 -> BlockLocator -> BlockHash -> GetHeaders
GetHeaders
            { getHeadersVersion :: Word32
getHeadersVersion = Word32
myVersion
            , getHeadersBL :: BlockLocator
getHeadersBL = BlockLocator
loc
            , getHeadersHashStop :: BlockHash
getHeadersHashStop = BlockHash
z
            }
  where
    z :: BlockHash
z = BlockHash
"0000000000000000000000000000000000000000000000000000000000000000"

-- | Set the time of last received data to now if a syncing peer is active.
setLastReceived :: MonadChain m => m ()
setLastReceived :: forall (m :: * -> *). MonadChain m => m ()
setLastReceived = do
    UTCTime
now <- IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
    TVar ChainState
st <- (ChainReader -> TVar ChainState) -> m (TVar ChainState)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChainReader -> TVar ChainState
chainState
    let f :: ChainSync -> ChainSync
f ChainSync
p = ChainSync
p { chainTimestamp :: UTCTime
chainTimestamp = UTCTime
now }
    STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ())
-> ((ChainState -> ChainState) -> STM ())
-> (ChainState -> ChainState)
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar ChainState -> (ChainState -> ChainState) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar ChainState
st ((ChainState -> ChainState) -> m ())
-> (ChainState -> ChainState) -> m ()
forall a b. (a -> b) -> a -> b
$ \ChainState
s ->
        ChainState
s { chainSyncing :: Maybe ChainSync
chainSyncing = ChainSync -> ChainSync
f (ChainSync -> ChainSync) -> Maybe ChainSync -> Maybe ChainSync
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainState -> Maybe ChainSync
chainSyncing ChainState
s }

-- | Add a new peer to the queue of peers to sync against.
addPeer :: MonadChain m => Peer -> m ()
addPeer :: forall (m :: * -> *). MonadChain m => Peer -> m ()
addPeer Peer
p = do
    TVar ChainState
st <- (ChainReader -> TVar ChainState) -> m (TVar ChainState)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChainReader -> TVar ChainState
chainState
    STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ())
-> ((ChainState -> ChainState) -> STM ())
-> (ChainState -> ChainState)
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar ChainState -> (ChainState -> ChainState) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar ChainState
st ((ChainState -> ChainState) -> m ())
-> (ChainState -> ChainState) -> m ()
forall a b. (a -> b) -> a -> b
$ \ChainState
s -> ChainState
s {newPeers :: [Peer]
newPeers = [Peer] -> [Peer]
forall a. Eq a => [a] -> [a]
nub (Peer
p Peer -> [Peer] -> [Peer]
forall a. a -> [a] -> [a]
: ChainState -> [Peer]
newPeers ChainState
s)}

-- | Get syncing peer if there is one.
getSyncingPeer :: MonadChain m => m (Maybe Peer)
getSyncingPeer :: forall (m :: * -> *). MonadChain m => m (Maybe Peer)
getSyncingPeer =
    (ChainSync -> Peer) -> Maybe ChainSync -> Maybe Peer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ChainSync -> Peer
chainSyncPeer (Maybe ChainSync -> Maybe Peer)
-> (ChainState -> Maybe ChainSync) -> ChainState -> Maybe Peer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainState -> Maybe ChainSync
chainSyncing (ChainState -> Maybe Peer) -> m ChainState -> m (Maybe Peer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TVar ChainState -> m ChainState
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (TVar ChainState -> m ChainState)
-> m (TVar ChainState) -> m ChainState
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (ChainReader -> TVar ChainState) -> m (TVar ChainState)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChainReader -> TVar ChainState
chainState)

setSyncingPeer :: MonadChain m => Peer -> m Bool
setSyncingPeer :: forall (m :: * -> *). MonadChain m => Peer -> m Bool
setSyncingPeer Peer
p =
    Peer -> m Bool
forall (m :: * -> *). MonadIO m => Peer -> m Bool
setBusy Peer
p m Bool -> (Bool -> m Bool) -> m Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Bool
False -> do
            $(logDebugS) Text
"Chain" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
                Text
"Could not lock peer: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
            Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Bool
True  -> do
            $(logDebugS) Text
"Chain" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
                Text
"Locked peer: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
            m ()
set_it
            Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
  where
    set_it :: m ()
set_it = do
        UTCTime
now <- IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
        TVar ChainState
box <- (ChainReader -> TVar ChainState) -> m (TVar ChainState)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChainReader -> TVar ChainState
chainState
        STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ TVar ChainState -> (ChainState -> ChainState) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar ChainState
box ((ChainState -> ChainState) -> STM ())
-> (ChainState -> ChainState) -> STM ()
forall a b. (a -> b) -> a -> b
$ \ChainState
s ->
            ChainState
s { chainSyncing :: Maybe ChainSync
chainSyncing =
                      ChainSync -> Maybe ChainSync
forall a. a -> Maybe a
Just ChainSync :: Peer -> UTCTime -> Maybe BlockNode -> ChainSync
ChainSync { chainSyncPeer :: Peer
chainSyncPeer = Peer
p
                                     , chainTimestamp :: UTCTime
chainTimestamp = UTCTime
now
                                     , chainHighest :: Maybe BlockNode
chainHighest = Maybe BlockNode
forall a. Maybe a
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 :: MonadChain m => Peer -> m ()
finishPeer :: forall (m :: * -> *). MonadChain m => Peer -> m ()
finishPeer Peer
p =
    (ChainReader -> TVar ChainState) -> m (TVar ChainState)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChainReader -> TVar ChainState
chainState m (TVar ChainState) -> (TVar ChainState -> m Bool) -> m Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TVar ChainState -> m Bool
forall {m :: * -> *}. MonadIO m => TVar ChainState -> m Bool
remove_peer m Bool -> (Bool -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Bool
False ->
            $(logDebugS) Text
"Chain" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
                Text
"Removed peer from queue: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
        Bool
True -> do
            $(logDebugS) Text
"Chain" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
                Text
"Releasing syncing peer: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
            Peer -> m ()
forall (m :: * -> *). MonadIO m => Peer -> m ()
setFree Peer
p
  where
    remove_peer :: TVar ChainState -> m Bool
remove_peer TVar ChainState
st = STM Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Bool -> m Bool) -> STM Bool -> m Bool
forall a b. (a -> b) -> a -> b
$
        TVar ChainState -> STM ChainState
forall a. TVar a -> STM a
readTVar TVar ChainState
st STM ChainState -> (ChainState -> STM Bool) -> STM Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ChainState
s -> case ChainState -> Maybe ChainSync
chainSyncing ChainState
s of
            Just ChainSync { chainSyncPeer :: ChainSync -> Peer
chainSyncPeer = Peer
p' }
                | Peer
p Peer -> Peer -> Bool
forall a. Eq a => a -> a -> Bool
== Peer
p' -> do
                      TVar ChainState -> STM ()
unset_syncing TVar ChainState
st
                      Bool -> STM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
            Maybe ChainSync
_ -> do
                TVar ChainState -> STM ()
remove_from_queue TVar ChainState
st
                Bool -> STM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    unset_syncing :: TVar ChainState -> STM ()
unset_syncing TVar ChainState
st =
        TVar ChainState -> (ChainState -> ChainState) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar ChainState
st ((ChainState -> ChainState) -> STM ())
-> (ChainState -> ChainState) -> STM ()
forall a b. (a -> b) -> a -> b
$ \ChainState
x ->
            ChainState
x { chainSyncing :: Maybe ChainSync
chainSyncing = Maybe ChainSync
forall a. Maybe a
Nothing }
    remove_from_queue :: TVar ChainState -> STM ()
remove_from_queue TVar ChainState
st =
        TVar ChainState -> (ChainState -> ChainState) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar ChainState
st ((ChainState -> ChainState) -> STM ())
-> (ChainState -> ChainState) -> STM ()
forall a b. (a -> b) -> a -> b
$ \ChainState
x ->
            ChainState
x { newPeers :: [Peer]
newPeers = Peer -> [Peer] -> [Peer]
forall a. Eq a => a -> [a] -> [a]
delete Peer
p (ChainState -> [Peer]
newPeers ChainState
x) }

-- | Return syncing peer data.
chainSyncingPeer :: MonadChain m => m (Maybe ChainSync)
chainSyncingPeer :: forall (m :: * -> *). MonadChain m => m (Maybe ChainSync)
chainSyncingPeer =
    ChainState -> Maybe ChainSync
chainSyncing (ChainState -> Maybe ChainSync)
-> m ChainState -> m (Maybe ChainSync)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TVar ChainState -> m ChainState
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (TVar ChainState -> m ChainState)
-> m (TVar ChainState) -> m ChainState
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (ChainReader -> TVar ChainState) -> m (TVar ChainState)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChainReader -> TVar ChainState
chainState)

-- | Get a block header from 'Chain' process.
chainGetBlock :: MonadIO m
              => BlockHash -> Chain -> m (Maybe BlockNode)
chainGetBlock :: forall (m :: * -> *).
MonadIO m =>
BlockHash -> Chain -> m (Maybe BlockNode)
chainGetBlock BlockHash
bh Chain
ch =
    ReaderT ChainConfig m (Maybe BlockNode)
-> ChainConfig -> m (Maybe BlockNode)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (BlockHash -> ReaderT ChainConfig m (Maybe BlockNode)
forall (m :: * -> *).
BlockHeaders m =>
BlockHash -> m (Maybe BlockNode)
getBlockHeader BlockHash
bh) (ChainReader -> ChainConfig
myConfig (Chain -> ChainReader
chainReader Chain
ch))

-- | Get best block header from chain process.
chainGetBest :: MonadIO m => Chain -> m BlockNode
chainGetBest :: forall (m :: * -> *). MonadIO m => Chain -> m BlockNode
chainGetBest Chain
ch =
    ReaderT ChainConfig m BlockNode -> ChainConfig -> m BlockNode
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT ChainConfig m BlockNode
forall (m :: * -> *). BlockHeaders m => m BlockNode
getBestBlockHeader (ChainReader -> ChainConfig
myConfig (Chain -> ChainReader
chainReader Chain
ch))

-- | Get ancestor of 'BlockNode' at 'BlockHeight' from chain process.
chainGetAncestor :: MonadIO m
                 => BlockHeight
                 -> BlockNode
                 -> Chain
                 -> m (Maybe BlockNode)
chainGetAncestor :: forall (m :: * -> *).
MonadIO m =>
Word32 -> BlockNode -> Chain -> m (Maybe BlockNode)
chainGetAncestor Word32
h BlockNode
bn Chain
ch =
    ReaderT ChainConfig m (Maybe BlockNode)
-> ChainConfig -> m (Maybe BlockNode)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Word32 -> BlockNode -> ReaderT ChainConfig m (Maybe BlockNode)
forall (m :: * -> *).
BlockHeaders m =>
Word32 -> BlockNode -> m (Maybe BlockNode)
getAncestor Word32
h BlockNode
bn) (ChainReader -> ChainConfig
myConfig (Chain -> ChainReader
chainReader Chain
ch))

-- | Get parents of 'BlockNode' starting at 'BlockHeight' from chain process.
chainGetParents :: MonadIO m
                => BlockHeight
                -> BlockNode
                -> Chain
                -> m [BlockNode]
chainGetParents :: forall (m :: * -> *).
MonadIO m =>
Word32 -> BlockNode -> Chain -> m [BlockNode]
chainGetParents Word32
height BlockNode
top Chain
ch =
    [BlockNode] -> BlockNode -> m [BlockNode]
forall {m :: * -> *}.
MonadIO m =>
[BlockNode] -> BlockNode -> m [BlockNode]
go [] BlockNode
top
  where
    go :: [BlockNode] -> BlockNode -> m [BlockNode]
go [BlockNode]
acc BlockNode
b
        | Word32
height Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
>= BlockNode -> Word32
nodeHeight BlockNode
b = [BlockNode] -> m [BlockNode]
forall (m :: * -> *) a. Monad m => a -> m a
return [BlockNode]
acc
        | Bool
otherwise = do
            Maybe BlockNode
m <- BlockHash -> Chain -> m (Maybe BlockNode)
forall (m :: * -> *).
MonadIO m =>
BlockHash -> Chain -> m (Maybe BlockNode)
chainGetBlock (BlockHeader -> BlockHash
prevBlock (BlockHeader -> BlockHash) -> BlockHeader -> BlockHash
forall a b. (a -> b) -> a -> b
$ BlockNode -> BlockHeader
nodeHeader BlockNode
b) Chain
ch
            case Maybe BlockNode
m of
                Maybe BlockNode
Nothing -> [BlockNode] -> m [BlockNode]
forall (m :: * -> *) a. Monad m => a -> m a
return [BlockNode]
acc
                Just BlockNode
p  -> [BlockNode] -> BlockNode -> m [BlockNode]
go (BlockNode
p BlockNode -> [BlockNode] -> [BlockNode]
forall a. a -> [a] -> [a]
: [BlockNode]
acc) BlockNode
p

-- | Get last common block from chain process.
chainGetSplitBlock :: MonadIO m
                   => BlockNode
                   -> BlockNode
                   -> Chain
                   -> m BlockNode
chainGetSplitBlock :: forall (m :: * -> *).
MonadIO m =>
BlockNode -> BlockNode -> Chain -> m BlockNode
chainGetSplitBlock BlockNode
l BlockNode
r Chain
ch =
    ReaderT ChainConfig m BlockNode -> ChainConfig -> m BlockNode
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (BlockNode -> BlockNode -> ReaderT ChainConfig m BlockNode
forall (m :: * -> *).
BlockHeaders m =>
BlockNode -> BlockNode -> m BlockNode
splitPoint BlockNode
l BlockNode
r) (ChainReader -> ChainConfig
myConfig (Chain -> ChainReader
chainReader Chain
ch))

-- | Notify chain that a new peer is connected.
chainPeerConnected :: MonadIO m
                   => Peer
                   -> Chain
                   -> m ()
chainPeerConnected :: forall (m :: * -> *). MonadIO m => Peer -> Chain -> m ()
chainPeerConnected Peer
p Chain
ch =
    Peer -> ChainMessage
ChainPeerConnected Peer
p ChainMessage -> Mailbox ChainMessage -> m ()
forall (m :: * -> *) (mbox :: * -> *) msg.
(MonadIO m, OutChan mbox) =>
msg -> mbox msg -> m ()
`send` Chain -> Mailbox ChainMessage
chainMailbox Chain
ch

-- | Notify chain that a peer has disconnected.
chainPeerDisconnected :: MonadIO m
                      => Peer
                      -> Chain
                      -> m ()
chainPeerDisconnected :: forall (m :: * -> *). MonadIO m => Peer -> Chain -> m ()
chainPeerDisconnected Peer
p Chain
ch =
    Peer -> ChainMessage
ChainPeerDisconnected Peer
p ChainMessage -> Mailbox ChainMessage -> m ()
forall (m :: * -> *) (mbox :: * -> *) msg.
(MonadIO m, OutChan mbox) =>
msg -> mbox msg -> m ()
`send` Chain -> Mailbox ChainMessage
chainMailbox Chain
ch

-- | Is given 'BlockHash' in the main chain?
chainBlockMain :: MonadIO m
               => BlockHash
               -> Chain
               -> m Bool
chainBlockMain :: forall (m :: * -> *). MonadIO m => BlockHash -> Chain -> m Bool
chainBlockMain BlockHash
bh Chain
ch =
    Chain -> m BlockNode
forall (m :: * -> *). MonadIO m => Chain -> m BlockNode
chainGetBest Chain
ch m BlockNode -> (BlockNode -> m Bool) -> m Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \BlockNode
bb ->
    BlockHash -> Chain -> m (Maybe BlockNode)
forall (m :: * -> *).
MonadIO m =>
BlockHash -> Chain -> m (Maybe BlockNode)
chainGetBlock BlockHash
bh Chain
ch m (Maybe BlockNode) -> (Maybe BlockNode -> m Bool) -> m Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe BlockNode
Nothing ->
            Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        bm :: Maybe BlockNode
bm@(Just BlockNode
bn) ->
            (Maybe BlockNode -> Maybe BlockNode -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe BlockNode
bm) (Maybe BlockNode -> Bool) -> m (Maybe BlockNode) -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word32 -> BlockNode -> Chain -> m (Maybe BlockNode)
forall (m :: * -> *).
MonadIO m =>
Word32 -> BlockNode -> Chain -> m (Maybe BlockNode)
chainGetAncestor (BlockNode -> Word32
nodeHeight BlockNode
bn) BlockNode
bb Chain
ch

-- | Is chain in sync with network?
chainIsSynced :: MonadIO m => Chain -> m Bool
chainIsSynced :: forall (m :: * -> *). MonadIO m => Chain -> m Bool
chainIsSynced Chain
ch =
    ChainState -> Bool
mySynced (ChainState -> Bool) -> m ChainState -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar ChainState -> m ChainState
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (ChainReader -> TVar ChainState
chainState (Chain -> ChainReader
chainReader Chain
ch))

-- | Peer sends a bunch of headers to the chain process.
chainHeaders :: MonadIO m
             => Peer -> [BlockHeader] -> Chain -> m ()
chainHeaders :: forall (m :: * -> *).
MonadIO m =>
Peer -> [BlockHeader] -> Chain -> m ()
chainHeaders Peer
p [BlockHeader]
hs Chain
ch =
    Peer -> [BlockHeader] -> ChainMessage
ChainHeaders Peer
p [BlockHeader]
hs ChainMessage -> Mailbox ChainMessage -> m ()
forall (m :: * -> *) (mbox :: * -> *) msg.
(MonadIO m, OutChan mbox) =>
msg -> mbox msg -> m ()
`send` Chain -> Mailbox ChainMessage
chainMailbox Chain
ch