{-# 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
(==) = forall a. Eq a => a -> a -> 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
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
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
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
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
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
        forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Eq a => a -> a -> Bool
== Word8
0x92) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Get Word8
getWord8
        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
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
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
        forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Eq a => a -> a -> Bool
== Word8
0x90) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Get Word8
getWord8
        BlockHash -> BlockHeaderKey
BlockHeaderKey forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t. Serialize t => Get t
get
    put :: Putter BlockHeaderKey
put (BlockHeaderKey BlockHash
bh) = do
        Putter Word8
putWord8 Word8
0x90
        forall t. Serialize t => Putter t
put BlockHash
bh

-- | Key for best block in database.
data BestBlockKey = BestBlockKey deriving (BestBlockKey -> BestBlockKey -> Bool
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
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
        forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Eq a => a -> a -> Bool
== Word8
0x91) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Get Word8
getWord8
        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 <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChainConfig -> DB
chainConfDB
        forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChainConfig -> Maybe ColumnFamily
chainConfColumnFamily forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Maybe ColumnFamily
Nothing -> 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 -> 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 <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChainConfig -> DB
chainConfDB
        Maybe ColumnFamily
mcf <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChainConfig -> Maybe ColumnFamily
chainConfColumnFamily
        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 <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChainConfig -> DB
chainConfDB
        Maybe ColumnFamily
mcf <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChainConfig -> Maybe ColumnFamily
chainConfColumnFamily
        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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Maybe BlockNode
Nothing -> forall a. HasCallStack => String -> a
error String
"Could not get best block from database"
            Just BlockNode
b -> forall (m :: * -> *) a. Monad m => a -> m a
return BlockNode
b
    setBestBlockHeader :: BlockNode -> ReaderT ChainConfig m ()
setBestBlockHeader BlockNode
bn = do
        DB
db <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChainConfig -> DB
chainConfDB
        forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChainConfig -> Maybe ColumnFamily
chainConfColumnFamily forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Maybe ColumnFamily
Nothing -> 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 -> 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 <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChainConfig -> DB
chainConfDB
        Maybe ColumnFamily
mcf <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChainConfig -> Maybe ColumnFamily
chainConfColumnFamily
        forall (m :: * -> *). MonadIO m => DB -> [BatchOp] -> m ()
writeBatch DB
db (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   = 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 = 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 = forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
BlockHash -> Chain -> m (Maybe BlockNode)
chainGetBlock BlockHash
bh
    getBestBlockHeader :: ReaderT Chain m BlockNode
getBestBlockHeader = forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT forall (m :: * -> *). MonadIO m => Chain -> m BlockNode
chainGetBest
    addBlockHeader :: BlockNode -> ReaderT Chain m ()
addBlockHeader BlockNode
_ = forall a. HasCallStack => a
undefined
    setBestBlockHeader :: BlockNode -> ReaderT Chain m ()
setBestBlockHeader BlockNode
_ = forall a. HasCallStack => a
undefined
    addBlockHeaders :: [BlockNode] -> ReaderT Chain m ()
addBlockHeaders [BlockNode]
_ = 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 <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChainReader -> ChainConfig
myConfig
    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) <- forall (m :: * -> *) msg.
MonadUnliftIO m =>
m (Inbox msg, Mailbox msg)
newMailbox
    $(logDebugS) Text
"Chain" Text
"Starting chain actor"
    TVar ChainState
st <- forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO ChainState { chainSyncing :: Maybe ChainSync
chainSyncing = forall a. Maybe a
Nothing
                               , mySynced :: Bool
mySynced = Bool
False
                               , newPeers :: [Peer]
newPeers = []
                               }
    let rd :: ChainReader
rd = ChainReader { myConfig :: ChainConfig
myConfig = ChainConfig
cfg
                         , chainState :: TVar ChainState
chainState = TVar ChainState
st
                         }
        ch :: Chain
ch = Chain { chainReader :: ChainReader
chainReader = ChainReader
rd
                   , chainMailbox :: Mailbox ChainMessage
chainMailbox = Mailbox ChainMessage
mailbox
                   }
    forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT forall (m :: * -> *). MonadChain m => m ()
initChainDB ChainReader
rd
    forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> (Async a -> m b) -> m b
withAsync (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) forall a b. (a -> b) -> a -> b
$ \Async Any
a ->
        forall (m :: * -> *) a. MonadIO m => Async a -> m ()
link Async Any
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 = forall (m :: * -> *) a.
(MonadUnliftIO m, MonadLoggerIO m) =>
Chain -> m a -> m a
withSyncLoop Chain
ch forall a b. (a -> b) -> a -> b
$
        forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (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
        forall (m :: * -> *) a.
MonadChain m =>
ReaderT ChainConfig m a -> m a
withBlockHeaders forall (m :: * -> *). BlockHeaders m => m BlockNode
getBestBlockHeader forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
            forall (m :: * -> *). MonadChain m => ChainEvent -> m ()
chainEvent forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockNode -> ChainEvent
ChainBestBlock
        forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
            ChainMessage
msg <- forall (mbox :: * -> *) (m :: * -> *) msg.
(InChan mbox, MonadIO m) =>
mbox msg -> m msg
receive mbox ChainMessage
inbox
            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 <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ChainConfig -> Publisher ChainEvent
chainConfEvents forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainReader -> ChainConfig
myConfig)
    case ChainEvent
e of
        ChainBestBlock BlockNode
b ->
            $(logInfoS) Text
"Chain" forall a b. (a -> b) -> a -> b
$
            Text
"Best block header at height: "
            forall a. Semigroup a => a -> a -> a
<> forall a b. ConvertibleStrings a b => a -> b
cs (forall a. Show a => a -> String
show (BlockNode -> Word32
nodeHeight BlockNode
b))
        ChainSynced BlockNode
b ->
            $(logInfoS) Text
"Chain" forall a b. (a -> b) -> a -> b
$
            Text
"Headers in sync at height: "
            forall a. Semigroup a => a -> a -> a
<> forall a b. ConvertibleStrings a b => a -> b
cs (forall a. Show a => a -> String
show (BlockNode -> Word32
nodeHeight BlockNode
b))
    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" forall a b. (a -> b) -> a -> b
$
        Text
"Processing " forall a. Semigroup a => a -> a -> a
<> forall a b. ConvertibleStrings a b => a -> b
cs (forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [BlockHeader]
hs))
        forall a. Semigroup a => a -> a -> a
<> Text
" headers from peer: " forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
    Network
net <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ChainConfig -> Network
chainConfNetwork forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainReader -> ChainConfig
myConfig)
    UTCTime
now <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
    BlockNode
pbest <- forall (m :: * -> *) a.
MonadChain m =>
ReaderT ChainConfig m a -> m a
withBlockHeaders forall (m :: * -> *). BlockHeaders m => m BlockNode
getBestBlockHeader
    forall (m :: * -> *).
MonadChain m =>
Network
-> UTCTime -> [BlockHeader] -> m (Either PeerException Bool)
importHeaders Network
net UTCTime
now [BlockHeader]
hs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left PeerException
e -> do
            $(logErrorS) Text
"Chain" forall a b. (a -> b) -> a -> b
$
                Text
"Could not connect headers from peer: "
                forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
            PeerException
e forall (m :: * -> *). MonadIO m => PeerException -> Peer -> m ()
`killPeer` Peer
p
        Right Bool
done -> do
            forall (m :: * -> *). MonadChain m => m ()
setLastReceived
            BlockNode
best <- forall (m :: * -> *) a.
MonadChain m =>
ReaderT ChainConfig m a -> m a
withBlockHeaders forall (m :: * -> *). BlockHeaders m => m BlockNode
getBestBlockHeader
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BlockNode -> BlockHeader
nodeHeader BlockNode
pbest forall a. Eq a => a -> a -> Bool
/= BlockNode -> BlockHeader
nodeHeader BlockNode
best) forall a b. (a -> b) -> a -> b
$
                forall (m :: * -> *). MonadChain m => ChainEvent -> m ()
chainEvent (BlockNode -> ChainEvent
ChainBestBlock BlockNode
best)
            if Bool
done
                then do
                    Message
MSendHeaders forall (m :: * -> *). MonadIO m => Message -> Peer -> m ()
`sendMessage` Peer
p
                    forall (m :: * -> *). MonadChain m => Peer -> m ()
finishPeer Peer
p
                    forall (m :: * -> *). MonadChain m => m ()
syncNewPeer
                    forall (m :: * -> *). MonadChain m => m ()
syncNotif
                else forall (m :: * -> *). MonadChain m => Peer -> m ()
syncPeer Peer
p

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

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

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

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

chainMessage ChainMessage
ChainPing = do
    NominalDiffTime
to <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ChainConfig -> NominalDiffTime
chainConfTimeout forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainReader -> ChainConfig
myConfig)
    UTCTime
now <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
    forall (m :: * -> *). MonadChain m => m (Maybe ChainSync)
chainSyncingPeer 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 forall a. Ord a => a -> a -> Bool
> NominalDiffTime
to -> do
                $(logErrorS) Text
"Chain" forall a b. (a -> b) -> a -> b
$
                    Text
"Syncing peer timed out: " forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
                PeerException
PeerTimeout forall (m :: * -> *). MonadIO m => PeerException -> Peer -> m ()
`killPeer` Peer
p
            | Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Maybe ChainSync
Nothing -> 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 =
    forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> (Async a -> m b) -> m b
withAsync forall {b}. m b
go forall a b. (a -> b) -> a -> b
$ \Async Any
a ->
    forall (m :: * -> *) a. MonadIO m => Async a -> m ()
link Async Any
a forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m a
f
  where
    go :: m b
go = forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
        Int
delay <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
            forall a (m :: * -> *). (Random a, MonadIO m) => (a, a) -> m a
randomRIO (  Int
2 forall a. Num a => a -> a -> a
* Int
1000 forall a. Num a => a -> a -> a
* Int
1000
                      , Int
20 forall a. Num a => a -> a -> a
* Int
1000 forall a. Num a => a -> a -> a
* Int
1000 )
        forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay Int
delay
        ChainMessage
ChainPing 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 <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ChainConfig -> DB
chainConfDB forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainReader -> ChainConfig
myConfig)
    Maybe ColumnFamily
mcf <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ChainConfig -> Maybe ColumnFamily
chainConfColumnFamily forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainReader -> ChainConfig
myConfig)
    Network
net <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ChainConfig -> Network
chainConfNetwork forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainReader -> ChainConfig
myConfig)
    Maybe Word32
ver <- 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
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Word32
ver forall a. Eq a => a -> a -> Bool
/= forall a. a -> Maybe a
Just Word32
dataVersion) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadChain m => m [BatchOp]
purgeChainDB forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). MonadIO m => DB -> [BatchOp] -> m ()
writeBatch DB
db
    case Maybe ColumnFamily
mcf of
        Maybe ColumnFamily
Nothing -> 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 -> 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
    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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Maybe BlockNode
b ->
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isNothing (Maybe BlockNode
b :: Maybe BlockNode)) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a.
MonadChain m =>
ReaderT ChainConfig m a -> m a
withBlockHeaders forall a b. (a -> b) -> a -> b
$ do
            forall (m :: * -> *). BlockHeaders m => BlockNode -> m ()
addBlockHeader (Network -> BlockNode
genesisNode Network
net)
            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 <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ChainConfig -> DB
chainConfDB forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainReader -> ChainConfig
myConfig)
    Maybe ColumnFamily
mcf <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ChainConfig -> Maybe ColumnFamily
chainConfColumnFamily forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainReader -> ChainConfig
myConfig)
    forall {m :: * -> *} {a}.
MonadUnliftIO m =>
DB -> Maybe ColumnFamily -> (Iterator -> m a) -> m a
f DB
db Maybe ColumnFamily
mcf forall a b. (a -> b) -> a -> b
$ \Iterator
it -> do
        forall (m :: * -> *). MonadIO m => Iterator -> ByteString -> m ()
R.iterSeek Iterator
it forall a b. (a -> b) -> a -> b
$ Word8 -> ByteString
B.singleton Word8
0x90
        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   = forall (m :: * -> *) a.
MonadUnliftIO m =>
DB -> (Iterator -> m a) -> m a
R.withIter DB
db
    f DB
db (Just ColumnFamily
cf) = 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 =
        forall (m :: * -> *). MonadIO m => Iterator -> m (Maybe ByteString)
R.iterKey Iterator
it forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just ByteString
k
                | HasCallStack => ByteString -> Word8
B.head ByteString
k forall a. Eq a => a -> a -> Bool
== Word8
0x90 Bool -> Bool -> Bool
|| HasCallStack => ByteString -> Word8
B.head ByteString
k forall a. Eq a => a -> a -> Bool
== Word8
0x91 -> do
                    case Maybe ColumnFamily
mcf of
                        Maybe ColumnFamily
Nothing -> forall (m :: * -> *). MonadIO m => DB -> ByteString -> m ()
R.delete DB
db ByteString
k
                        Just ColumnFamily
cf -> forall (m :: * -> *).
MonadIO m =>
DB -> ColumnFamily -> ByteString -> m ()
R.deleteCF DB
db ColumnFamily
cf ByteString
k
                    forall (m :: * -> *). MonadIO m => Iterator -> m ()
R.iterNext Iterator
it
                    (ByteString -> BatchOp
R.Del ByteString
k forall a. a -> [a] -> [a]
:) 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
_ -> 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 =
    forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m (Either String [BlockNode])
connect forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Right [BlockNode]
_ -> do
            case [BlockHeader]
hs of
                [] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                [BlockHeader]
_ -> do
                    Maybe BlockNode
bb <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m (Maybe BlockNode)
get_last
                    TVar ChainState
box <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChainReader -> TVar ChainState
chainState
                    forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar ChainState
box 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})
                            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainState -> Maybe ChainSync
chainSyncing ChainState
s
                          }
            case forall (t :: * -> *) a. Foldable t => t a -> Int
length [BlockHeader]
hs of
                Int
2000 -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                Int
_    -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        Left String
_ -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError PeerException
PeerSentBadHeaders
  where
    timestamp :: Word32
timestamp = forall a b. (RealFrac a, Integral b) => a -> b
floor (UTCTime -> NominalDiffTime
utcTimeToPOSIXSeconds UTCTime
now)
    connect :: m (Either String [BlockNode])
connect = forall (m :: * -> *) a.
MonadChain m =>
ReaderT ChainConfig m a -> m a
withBlockHeaders forall a b. (a -> b) -> a -> b
$ 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 = forall (m :: * -> *) a.
MonadChain m =>
ReaderT ChainConfig m a -> m a
withBlockHeaders forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
BlockHeaders m =>
BlockHash -> m (Maybe BlockNode)
getBlockHeader forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockHeader -> BlockHash
headerHash forall a b. (a -> b) -> a -> b
$ 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 =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT forall a b. (a -> b) -> a -> b
$ do
        BlockNode
bb <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadChain m =>
ReaderT ChainConfig m a -> m a
withBlockHeaders forall (m :: * -> *). BlockHeaders m => m BlockNode
getBestBlockHeader
        UTCTime
now <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
        forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ UTCTime
now UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` BlockNode -> UTCTime
block_time BlockNode
bb forall a. Ord a => a -> a -> Bool
> NominalDiffTime
7200
        TVar ChainState
st <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChainReader -> TVar ChainState
chainState
        forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT forall a b. (a -> b) -> a -> b
$ do
            ChainState
s <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> STM a
readTVar TVar ChainState
st
            forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Maybe a -> Bool
isNothing forall a b. (a -> b) -> a -> b
$ ChainState -> Maybe ChainSync
chainSyncing ChainState
s
            forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ ChainState -> [Peer]
newPeers ChainState
s
            forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ ChainState -> Bool
mySynced ChainState
s
            forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> a -> STM ()
writeTVar TVar ChainState
st ChainState
s {mySynced :: Bool
mySynced = Bool
True}
            forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    block_time :: BlockNode -> UTCTime
block_time =
        NominalDiffTime -> UTCTime
posixSecondsToUTCTime forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockHeader -> Word32
blockTimestamp 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChainReader -> TVar ChainState
chainState)
    forall {m :: * -> *}.
(MonadLoggerIO m, MonadUnliftIO m, MonadReader ChainReader m) =>
[Peer] -> m (Maybe Peer)
go [Peer]
ps
  where
    go :: [Peer] -> m (Maybe Peer)
go [] = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    go (Peer
p:[Peer]
ps) =
        forall (m :: * -> *). MonadChain m => Peer -> m Bool
setSyncingPeer Peer
p forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Bool
True -> forall (m :: * -> *) a. Monad m => a -> m a
return (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 <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChainReader -> TVar ChainState
chainState
    forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$
        forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar ChainState
st forall a b. (a -> b) -> a -> b
$ \ChainState
s ->
            ChainState
s { chainSyncing :: Maybe ChainSync
chainSyncing =
                    forall a. a -> Maybe a
Just
                        ChainSync
                            { chainSyncPeer :: Peer
chainSyncPeer = Peer
p
                            , chainTimestamp :: UTCTime
chainTimestamp = UTCTime
now
                            , chainHighest :: Maybe BlockNode
chainHighest = forall a. Maybe a
Nothing
                            }
              , newPeers :: [Peer]
newPeers = forall a. Eq a => a -> [a] -> [a]
delete Peer
p (ChainState -> [Peer]
newPeers ChainState
s)
              }
    BlockLocator
loc <- forall (m :: * -> *) a.
MonadChain m =>
ReaderT ChainConfig m a -> m a
withBlockHeaders forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). BlockHeaders m => BlockNode -> m BlockLocator
blockLocator BlockNode
bb
    forall (m :: * -> *) a. Monad m => a -> m a
return
        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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
    TVar ChainState
st <- 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 }
    forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar ChainState
st forall a b. (a -> b) -> a -> b
$ \ChainState
s ->
        ChainState
s { chainSyncing :: Maybe ChainSync
chainSyncing = ChainSync -> ChainSync
f 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 <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChainReader -> TVar ChainState
chainState
    forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar ChainState
st forall a b. (a -> b) -> a -> b
$ \ChainState
s -> ChainState
s {newPeers :: [Peer]
newPeers = forall a. Eq a => [a] -> [a]
nub (Peer
p 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 =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ChainSync -> Peer
chainSyncPeer forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainState -> Maybe ChainSync
chainSyncing forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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 =
    forall (m :: * -> *). MonadIO m => Peer -> m Bool
setBusy Peer
p forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Bool
False -> do
            $(logDebugS) Text
"Chain" forall a b. (a -> b) -> a -> b
$
                Text
"Could not lock peer: " forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
            forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Bool
True  -> do
            $(logDebugS) Text
"Chain" forall a b. (a -> b) -> a -> b
$
                Text
"Locked peer: " forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
            m ()
set_it
            forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
  where
    set_it :: m ()
set_it = do
        UTCTime
now <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
        TVar ChainState
box <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChainReader -> TVar ChainState
chainState
        forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar ChainState
box forall a b. (a -> b) -> a -> b
$ \ChainState
s ->
            ChainState
s { chainSyncing :: Maybe ChainSync
chainSyncing =
                      forall a. a -> Maybe a
Just ChainSync { chainSyncPeer :: Peer
chainSyncPeer = Peer
p
                                     , chainTimestamp :: UTCTime
chainTimestamp = UTCTime
now
                                     , chainHighest :: Maybe BlockNode
chainHighest = 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 =
    forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChainReader -> TVar ChainState
chainState forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {m :: * -> *}. MonadIO m => TVar ChainState -> m Bool
remove_peer forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Bool
False ->
            $(logDebugS) Text
"Chain" forall a b. (a -> b) -> a -> b
$
                Text
"Removed peer from queue: " forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
        Bool
True -> do
            $(logDebugS) Text
"Chain" forall a b. (a -> b) -> a -> b
$
                Text
"Releasing syncing peer: " forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
            forall (m :: * -> *). MonadIO m => Peer -> m ()
setFree Peer
p
  where
    remove_peer :: TVar ChainState -> m Bool
remove_peer TVar ChainState
st = forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$
        forall a. TVar a -> STM a
readTVar TVar ChainState
st 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 forall a. Eq a => a -> a -> Bool
== Peer
p' -> do
                      TVar ChainState -> STM ()
unset_syncing TVar ChainState
st
                      forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
            Maybe ChainSync
_ -> do
                TVar ChainState -> STM ()
remove_from_queue TVar ChainState
st
                forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    unset_syncing :: TVar ChainState -> STM ()
unset_syncing TVar ChainState
st =
        forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar ChainState
st forall a b. (a -> b) -> a -> b
$ \ChainState
x ->
            ChainState
x { chainSyncing :: Maybe ChainSync
chainSyncing = forall a. Maybe a
Nothing }
    remove_from_queue :: TVar ChainState -> STM ()
remove_from_queue TVar ChainState
st =
        forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar ChainState
st forall a b. (a -> b) -> a -> b
$ \ChainState
x ->
            ChainState
x { newPeers :: [Peer]
newPeers = 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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 =
    forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (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 =
    forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT 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 =
    forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (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 =
    forall {m :: * -> *}.
MonadIO m =>
[BlockNode] -> BlockNode -> m [BlockNode]
go [] BlockNode
top
  where
    go :: [BlockNode] -> BlockNode -> m [BlockNode]
go [BlockNode]
acc BlockNode
b
        | Word32
height forall a. Ord a => a -> a -> Bool
>= BlockNode -> Word32
nodeHeight BlockNode
b = forall (m :: * -> *) a. Monad m => a -> m a
return [BlockNode]
acc
        | Bool
otherwise = do
            Maybe BlockNode
m <- forall (m :: * -> *).
MonadIO m =>
BlockHash -> Chain -> m (Maybe BlockNode)
chainGetBlock (BlockHeader -> BlockHash
prevBlock forall a b. (a -> b) -> a -> b
$ BlockNode -> BlockHeader
nodeHeader BlockNode
b) Chain
ch
            case Maybe BlockNode
m of
                Maybe BlockNode
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return [BlockNode]
acc
                Just BlockNode
p  -> [BlockNode] -> BlockNode -> m [BlockNode]
go (BlockNode
p 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 =
    forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (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 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 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 =
    forall (m :: * -> *). MonadIO m => Chain -> m BlockNode
chainGetBest Chain
ch forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \BlockNode
bb ->
    forall (m :: * -> *).
MonadIO m =>
BlockHash -> Chain -> m (Maybe BlockNode)
chainGetBlock BlockHash
bh Chain
ch forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe BlockNode
Nothing ->
            forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        bm :: Maybe BlockNode
bm@(Just BlockNode
bn) ->
            (forall a. Eq a => a -> a -> Bool
== Maybe BlockNode
bm) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 forall (m :: * -> *) (mbox :: * -> *) msg.
(MonadIO m, OutChan mbox) =>
msg -> mbox msg -> m ()
`send` Chain -> Mailbox ChainMessage
chainMailbox Chain
ch