{-# 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
$cp1Ord :: Eq ChainDataVersionKey
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
== 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 = Putter Word8
putWord8 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
== 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 bh :: BlockHash
bh) = do
        Putter Word8
putWord8 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
== 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 = Putter Word8
putWord8 0x91

instance MonadIO m => BlockHeaders (ReaderT ChainConfig m) where
    addBlockHeader :: BlockNode -> ReaderT ChainConfig m ()
addBlockHeader bn :: 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
            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 cf :: 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 bh :: 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
            Nothing -> String -> ReaderT ChainConfig m BlockNode
forall a. HasCallStack => String -> a
error "Could not get best block from database"
            Just b :: BlockNode
b -> BlockNode -> ReaderT ChainConfig m BlockNode
forall (m :: * -> *) a. Monad m => a -> m a
return BlockNode
b
    setBestBlockHeader :: BlockNode -> ReaderT ChainConfig m ()
setBestBlockHeader bn :: 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
            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 cf :: 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 bns :: [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 bn :: BlockNode
bn = BlockHeader -> BlockHash
headerHash (BlockNode -> BlockHeader
nodeHeader BlockNode
bn)
        f :: Maybe ColumnFamily -> BlockNode -> BatchOp
f Nothing bn :: 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 cf :: ColumnFamily
cf) bn :: 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 bh :: 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 _ = ReaderT Chain m ()
forall a. HasCallStack => a
undefined
    setBestBlockHeader :: BlockNode -> ReaderT Chain m ()
setBestBlockHeader _ = ReaderT Chain m ()
forall a. HasCallStack => a
undefined
    addBlockHeaders :: [BlockNode] -> ReaderT Chain m ()
addBlockHeaders _ = ReaderT Chain m ()
forall a. HasCallStack => a
undefined

withBlockHeaders :: MonadChain m => ReaderT ChainConfig m a -> m a
withBlockHeaders :: ReaderT ChainConfig m a -> m a
withBlockHeaders f :: 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 :: ChainConfig -> (Chain -> m a) -> m a
withChain cfg :: ChainConfig
cfg action :: Chain -> m a
action = do
    (inbox :: Inbox ChainMessage
inbox, mailbox :: Mailbox ChainMessage
mailbox) <- m (Inbox ChainMessage, Mailbox ChainMessage)
forall (m :: * -> *) msg.
MonadUnliftIO m =>
m (Inbox msg, Mailbox msg)
newMailbox
    $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
logDebugS) "Chain" "Starting chain actor"
    TVar ChainState
st <- ChainState -> m (TVar ChainState)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO $WChainState :: 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 = $WChainReader :: ChainConfig -> TVar ChainState -> ChainReader
ChainReader { myConfig :: ChainConfig
myConfig = ChainConfig
cfg
                         , chainState :: TVar ChainState
chainState = TVar ChainState
st
                         }
        ch :: Chain
ch = $WChain :: Mailbox ChainMessage -> ChainReader -> Chain
Chain { chainReader :: ChainReader
chainReader = ChainReader
rd
                   , chainMailbox :: Mailbox ChainMessage
chainMailbox = Mailbox ChainMessage
mailbox
                   }
    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
$ \a :: 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 ch :: Chain
ch rd :: ChainReader
rd inbox :: 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
$
        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 ReaderT ChainReader m a -> ChainReader -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` ChainReader
rd
    run :: mbox ChainMessage -> m b
run inbox :: mbox ChainMessage
inbox = do
        m ()
forall (m :: * -> *). MonadChain m => m ()
initChainDB
        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 :: ChainEvent -> m ()
chainEvent e :: 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 b :: BlockNode
b ->
            $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logInfoS) "Chain" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
            "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 b :: BlockNode
b ->
            $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logInfoS) "Chain" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
            "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 :: Peer -> [BlockHeader] -> m ()
processHeaders p :: Peer
p hs :: [BlockHeader]
hs = do
    $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logDebugS) "Chain" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
        "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
<> " 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 e :: PeerException
e -> do
            $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logErrorS) "Chain" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
                "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 done :: 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 :: 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 _  -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    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
        Nothing -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just p :: Peer
p -> do
            $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logDebugS) "Chain" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
                "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 :: 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
        False -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        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 :: Peer -> m ()
syncPeer p :: 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
        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
$ \g :: GetHeaders
g -> do
        $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logDebugS) "Chain" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
            "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 t :: 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
            False -> Maybe GetHeaders -> m (Maybe GetHeaders)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe GetHeaders
forall a. Maybe a
Nothing
            True -> do
                $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logDebugS) "Chain" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
                    "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 t :: UTCTime
t m :: Maybe BlockNode
m = do
        BlockNode
h <- case Maybe BlockNode
m of
                 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 h :: 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 :: ChainMessage -> m ()
chainMessage (ChainHeaders p :: Peer
p hs :: [BlockHeader]
hs) =
    Peer -> [BlockHeader] -> m ()
forall (m :: * -> *). MonadChain m => Peer -> [BlockHeader] -> m ()
processHeaders Peer
p [BlockHeader]
hs

chainMessage (ChainPeerConnected p :: Peer
p) = do
    $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logDebugS) "Chain" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ "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 p :: Peer
p) = do
    $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logDebugS) "Chain" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ "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 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
                $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logErrorS) "Chain" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
                    "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 ()
        Nothing -> m ()
forall (m :: * -> *). MonadChain m => m ()
syncNewPeer

withSyncLoop :: (MonadUnliftIO m, MonadLoggerIO m)
             => Chain -> m a -> m a
withSyncLoop :: Chain -> m a -> m a
withSyncLoop ch :: Chain
ch f :: 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
$ \a :: 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 (  2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* 1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* 1000
                      , 20 Int -> Int -> Int
forall a. Num a => a -> a -> a
* 1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* 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 = 1

-- | Initialize header database. If version is different from current, the
-- database is purged of conflicting elements first.
initChainDB :: MonadChain m => m ()
initChainDB :: 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
        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 cf :: 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
>>= \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 :: 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
$ \it :: 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 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
db 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
db (Just cf :: 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 it :: Iterator
it db :: DB
db mcf :: 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 k :: ByteString
k
                | ByteString -> Word8
B.head ByteString
k Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== 0x90 Bool -> Bool -> Bool
|| ByteString -> Word8
B.head ByteString
k Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== 0x91 -> do
                    case Maybe ColumnFamily
mcf of
                        Nothing -> DB -> ByteString -> m ()
forall (m :: * -> *). MonadIO m => DB -> ByteString -> m ()
R.delete DB
db ByteString
k
                        Just cf :: 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
            _ -> [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 :: Network
-> UTCTime -> [BlockHeader] -> m (Either PeerException Bool)
importHeaders net :: Network
net now :: UTCTime
now hs :: [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 _ -> do
            case [BlockHeader]
hs of
                [] -> () -> ExceptT PeerException m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                _ -> 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
$ \s :: ChainState
s ->
                        ChainState
s { chainSyncing :: Maybe ChainSync
chainSyncing =
                            (\x :: 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
                2000 -> Bool -> ExceptT PeerException m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                _    -> Bool -> ExceptT PeerException m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        Left _ -> 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 :: 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
> 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 :: 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 (p :: Peer
p:ps :: [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
            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)
            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 :: UTCTime -> BlockNode -> Peer -> m GetHeaders
syncHeaders now :: UTCTime
now bb :: BlockNode
bb p :: 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
$ \s :: ChainState
s ->
            ChainState
s { chainSyncing :: Maybe ChainSync
chainSyncing =
                    ChainSync -> Maybe ChainSync
forall a. a -> Maybe a
Just
                        $WChainSync :: 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
        $WGetHeaders :: Word32 -> BlockLocator -> BlockHash -> GetHeaders
GetHeaders
            { getHeadersVersion :: Word32
getHeadersVersion = Word32
myVersion
            , getHeadersBL :: BlockLocator
getHeadersBL = BlockLocator
loc
            , getHeadersHashStop :: BlockHash
getHeadersHashStop = BlockHash
z
            }
  where
    z :: BlockHash
z = "0000000000000000000000000000000000000000000000000000000000000000"

-- | Set the time of last received data to now if a syncing peer is active.
setLastReceived :: MonadChain m => m ()
setLastReceived :: 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 p :: 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
$ \s :: 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 :: Peer -> m ()
addPeer p :: 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
$ \s :: 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 :: 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 :: Peer -> m Bool
setSyncingPeer p :: 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
        False -> do
            $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logDebugS) "Chain" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
                "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
        True  -> do
            $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logDebugS) "Chain" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
                "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
$ \s :: ChainState
s ->
            ChainState
s { chainSyncing :: Maybe ChainSync
chainSyncing =
                      ChainSync -> Maybe ChainSync
forall a. a -> Maybe a
Just $WChainSync :: 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 :: Peer -> m ()
finishPeer p :: 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
        False ->
            $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logDebugS) "Chain" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
                "Removed peer from queue: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
        True -> do
            $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logDebugS) "Chain" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
                "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 st :: 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
>>= \s :: 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
            _ -> 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 st :: 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
$ \x :: ChainState
x ->
            ChainState
x { chainSyncing :: Maybe ChainSync
chainSyncing = Maybe ChainSync
forall a. Maybe a
Nothing }
    remove_from_queue :: TVar ChainState -> STM ()
remove_from_queue st :: 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
$ \x :: 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 :: 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 :: BlockHash -> Chain -> m (Maybe BlockNode)
chainGetBlock bh :: BlockHash
bh ch :: 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 :: Chain -> m BlockNode
chainGetBest ch :: 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 :: Word32 -> BlockNode -> Chain -> m (Maybe BlockNode)
chainGetAncestor h :: Word32
h bn :: BlockNode
bn ch :: 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 :: Word32 -> BlockNode -> Chain -> m [BlockNode]
chainGetParents height :: Word32
height top :: BlockNode
top ch :: Chain
ch =
    [BlockNode] -> BlockNode -> m [BlockNode]
forall (m :: * -> *).
MonadIO m =>
[BlockNode] -> BlockNode -> m [BlockNode]
go [] BlockNode
top
  where
    go :: [BlockNode] -> BlockNode -> m [BlockNode]
go acc :: [BlockNode]
acc b :: 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
                Nothing -> [BlockNode] -> m [BlockNode]
forall (m :: * -> *) a. Monad m => a -> m a
return [BlockNode]
acc
                Just p :: 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 :: BlockNode -> BlockNode -> Chain -> m BlockNode
chainGetSplitBlock l :: BlockNode
l r :: BlockNode
r ch :: 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 :: Peer -> Chain -> m ()
chainPeerConnected p :: Peer
p ch :: 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 :: Peer -> Chain -> m ()
chainPeerDisconnected p :: Peer
p ch :: 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 :: BlockHash -> Chain -> m Bool
chainBlockMain bh :: BlockHash
bh ch :: 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
>>= \bb :: 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
        Nothing ->
            Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        bm :: Maybe BlockNode
bm@(Just bn :: 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 :: Chain -> m Bool
chainIsSynced ch :: 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 :: Peer -> [BlockHeader] -> Chain -> m ()
chainHeaders p :: Peer
p hs :: [BlockHeader]
hs ch :: 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