{-# 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)
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
data ChainConfig =
ChainConfig
{ ChainConfig -> DB
chainConfDB :: !DB
, ChainConfig -> Maybe ColumnFamily
chainConfColumnFamily :: !(Maybe ColumnFamily)
, ChainConfig -> Network
chainConfNetwork :: !Network
, ChainConfig -> Publisher ChainEvent
chainConfEvents :: !(Publisher ChainEvent)
, ChainConfig -> NominalDiffTime
chainConfTimeout :: !NominalDiffTime
}
data ChainMessage
= !Peer ![BlockHeader]
| ChainPeerConnected !Peer
| ChainPeerDisconnected !Peer
| ChainPing
data ChainEvent
= ChainBestBlock !BlockNode
| ChainSynced !BlockNode
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 )
data ChainReader = ChainReader
{ ChainReader -> ChainConfig
myConfig :: !ChainConfig
, ChainReader -> TVar ChainState
chainState :: !(TVar ChainState)
}
data ChainDataVersionKey = ChainDataVersionKey
deriving (ChainDataVersionKey -> ChainDataVersionKey -> Bool
(ChainDataVersionKey -> ChainDataVersionKey -> Bool)
-> (ChainDataVersionKey -> ChainDataVersionKey -> Bool)
-> Eq ChainDataVersionKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ChainDataVersionKey -> ChainDataVersionKey -> Bool
$c/= :: ChainDataVersionKey -> ChainDataVersionKey -> Bool
== :: ChainDataVersionKey -> ChainDataVersionKey -> Bool
$c== :: ChainDataVersionKey -> ChainDataVersionKey -> Bool
Eq, Eq ChainDataVersionKey
Eq ChainDataVersionKey
-> (ChainDataVersionKey -> ChainDataVersionKey -> Ordering)
-> (ChainDataVersionKey -> ChainDataVersionKey -> Bool)
-> (ChainDataVersionKey -> ChainDataVersionKey -> Bool)
-> (ChainDataVersionKey -> ChainDataVersionKey -> Bool)
-> (ChainDataVersionKey -> ChainDataVersionKey -> Bool)
-> (ChainDataVersionKey
-> ChainDataVersionKey -> ChainDataVersionKey)
-> (ChainDataVersionKey
-> ChainDataVersionKey -> ChainDataVersionKey)
-> Ord ChainDataVersionKey
ChainDataVersionKey -> ChainDataVersionKey -> Bool
ChainDataVersionKey -> ChainDataVersionKey -> Ordering
ChainDataVersionKey -> ChainDataVersionKey -> ChainDataVersionKey
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ChainDataVersionKey -> ChainDataVersionKey -> ChainDataVersionKey
$cmin :: ChainDataVersionKey -> ChainDataVersionKey -> ChainDataVersionKey
max :: ChainDataVersionKey -> ChainDataVersionKey -> ChainDataVersionKey
$cmax :: ChainDataVersionKey -> ChainDataVersionKey -> ChainDataVersionKey
>= :: ChainDataVersionKey -> ChainDataVersionKey -> Bool
$c>= :: ChainDataVersionKey -> ChainDataVersionKey -> Bool
> :: ChainDataVersionKey -> ChainDataVersionKey -> Bool
$c> :: ChainDataVersionKey -> ChainDataVersionKey -> Bool
<= :: ChainDataVersionKey -> ChainDataVersionKey -> Bool
$c<= :: ChainDataVersionKey -> ChainDataVersionKey -> Bool
< :: ChainDataVersionKey -> ChainDataVersionKey -> Bool
$c< :: ChainDataVersionKey -> ChainDataVersionKey -> Bool
compare :: ChainDataVersionKey -> ChainDataVersionKey -> Ordering
$ccompare :: ChainDataVersionKey -> ChainDataVersionKey -> Ordering
Ord, Int -> ChainDataVersionKey -> ShowS
[ChainDataVersionKey] -> ShowS
ChainDataVersionKey -> String
(Int -> ChainDataVersionKey -> ShowS)
-> (ChainDataVersionKey -> String)
-> ([ChainDataVersionKey] -> ShowS)
-> Show ChainDataVersionKey
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ChainDataVersionKey] -> ShowS
$cshowList :: [ChainDataVersionKey] -> ShowS
show :: ChainDataVersionKey -> String
$cshow :: ChainDataVersionKey -> String
showsPrec :: Int -> ChainDataVersionKey -> ShowS
$cshowsPrec :: Int -> ChainDataVersionKey -> ShowS
Show)
instance Key ChainDataVersionKey
instance KeyValue ChainDataVersionKey Word32
instance Serialize ChainDataVersionKey where
get :: Get ChainDataVersionKey
get = do
Bool -> Get ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Get ()) -> (Word8 -> Bool) -> Word8 -> Get ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x92) (Word8 -> Get ()) -> Get Word8 -> Get ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Get Word8
getWord8
ChainDataVersionKey -> Get ChainDataVersionKey
forall (m :: * -> *) a. Monad m => a -> m a
return ChainDataVersionKey
ChainDataVersionKey
put :: Putter ChainDataVersionKey
put ChainDataVersionKey
ChainDataVersionKey = Putter Word8
putWord8 Word8
0x92
data ChainSync = ChainSync
{ ChainSync -> Peer
chainSyncPeer :: !Peer
, ChainSync -> UTCTime
chainTimestamp :: !UTCTime
, ChainSync -> Maybe BlockNode
chainHighest :: !(Maybe BlockNode)
}
data ChainState = ChainState
{ ChainState -> Maybe ChainSync
chainSyncing :: !(Maybe ChainSync)
, ChainState -> [Peer]
newPeers :: ![Peer]
, ChainState -> Bool
mySynced :: !Bool
}
newtype = BlockHash deriving (BlockHeaderKey -> BlockHeaderKey -> Bool
(BlockHeaderKey -> BlockHeaderKey -> Bool)
-> (BlockHeaderKey -> BlockHeaderKey -> Bool) -> Eq BlockHeaderKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BlockHeaderKey -> BlockHeaderKey -> Bool
$c/= :: BlockHeaderKey -> BlockHeaderKey -> Bool
== :: BlockHeaderKey -> BlockHeaderKey -> Bool
$c== :: BlockHeaderKey -> BlockHeaderKey -> Bool
Eq, Int -> BlockHeaderKey -> ShowS
[BlockHeaderKey] -> ShowS
BlockHeaderKey -> String
(Int -> BlockHeaderKey -> ShowS)
-> (BlockHeaderKey -> String)
-> ([BlockHeaderKey] -> ShowS)
-> Show BlockHeaderKey
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BlockHeaderKey] -> ShowS
$cshowList :: [BlockHeaderKey] -> ShowS
show :: BlockHeaderKey -> String
$cshow :: BlockHeaderKey -> String
showsPrec :: Int -> BlockHeaderKey -> ShowS
$cshowsPrec :: Int -> BlockHeaderKey -> ShowS
Show)
instance Serialize BlockHeaderKey where
get :: Get BlockHeaderKey
get = do
Bool -> Get ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Get ()) -> (Word8 -> Bool) -> Word8 -> Get ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x90) (Word8 -> Get ()) -> Get Word8 -> Get ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Get Word8
getWord8
BlockHash -> BlockHeaderKey
BlockHeaderKey (BlockHash -> BlockHeaderKey)
-> Get BlockHash -> Get BlockHeaderKey
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get BlockHash
forall t. Serialize t => Get t
get
put :: Putter BlockHeaderKey
put (BlockHeaderKey BlockHash
bh) = do
Putter Word8
putWord8 Word8
0x90
Putter BlockHash
forall t. Serialize t => Putter t
put BlockHash
bh
data BestBlockKey = BestBlockKey deriving (BestBlockKey -> BestBlockKey -> Bool
(BestBlockKey -> BestBlockKey -> Bool)
-> (BestBlockKey -> BestBlockKey -> Bool) -> Eq BestBlockKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BestBlockKey -> BestBlockKey -> Bool
$c/= :: BestBlockKey -> BestBlockKey -> Bool
== :: BestBlockKey -> BestBlockKey -> Bool
$c== :: BestBlockKey -> BestBlockKey -> Bool
Eq, Int -> BestBlockKey -> ShowS
[BestBlockKey] -> ShowS
BestBlockKey -> String
(Int -> BestBlockKey -> ShowS)
-> (BestBlockKey -> String)
-> ([BestBlockKey] -> ShowS)
-> Show BestBlockKey
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BestBlockKey] -> ShowS
$cshowList :: [BestBlockKey] -> ShowS
show :: BestBlockKey -> String
$cshow :: BestBlockKey -> String
showsPrec :: Int -> BestBlockKey -> ShowS
$cshowsPrec :: Int -> BestBlockKey -> ShowS
Show)
instance KeyValue BlockHeaderKey BlockNode
instance KeyValue BestBlockKey BlockNode
instance Serialize BestBlockKey where
get :: Get BestBlockKey
get = do
Bool -> Get ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Get ()) -> (Word8 -> Bool) -> Word8 -> Get ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x91) (Word8 -> Get ()) -> Get Word8 -> Get ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Get Word8
getWord8
BestBlockKey -> Get BestBlockKey
forall (m :: * -> *) a. Monad m => a -> m a
return BestBlockKey
BestBlockKey
put :: Putter BestBlockKey
put BestBlockKey
BestBlockKey = Putter Word8
putWord8 Word8
0x91
instance MonadIO m => BlockHeaders (ReaderT ChainConfig m) where
addBlockHeader :: BlockNode -> ReaderT ChainConfig m ()
addBlockHeader BlockNode
bn = do
DB
db <- (ChainConfig -> DB) -> ReaderT ChainConfig m DB
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChainConfig -> DB
chainConfDB
(ChainConfig -> Maybe ColumnFamily)
-> ReaderT ChainConfig m (Maybe ColumnFamily)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChainConfig -> Maybe ColumnFamily
chainConfColumnFamily ReaderT ChainConfig m (Maybe ColumnFamily)
-> (Maybe ColumnFamily -> ReaderT ChainConfig m ())
-> ReaderT ChainConfig m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe ColumnFamily
Nothing -> DB -> BlockHeaderKey -> BlockNode -> ReaderT ChainConfig m ()
forall (m :: * -> *) key value.
(MonadIO m, KeyValue key value, Serialize key, Serialize value) =>
DB -> key -> value -> m ()
insert DB
db (BlockHash -> BlockHeaderKey
BlockHeaderKey BlockHash
h) BlockNode
bn
Just ColumnFamily
cf -> DB
-> ColumnFamily
-> BlockHeaderKey
-> BlockNode
-> ReaderT ChainConfig m ()
forall (m :: * -> *) key value.
(MonadIO m, KeyValue key value, Serialize key, Serialize value) =>
DB -> ColumnFamily -> key -> value -> m ()
insertCF DB
db ColumnFamily
cf (BlockHash -> BlockHeaderKey
BlockHeaderKey BlockHash
h) BlockNode
bn
where
h :: BlockHash
h = BlockHeader -> BlockHash
headerHash (BlockNode -> BlockHeader
nodeHeader BlockNode
bn)
getBlockHeader :: BlockHash -> ReaderT ChainConfig m (Maybe BlockNode)
getBlockHeader BlockHash
bh = do
DB
db <- (ChainConfig -> DB) -> ReaderT ChainConfig m DB
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChainConfig -> DB
chainConfDB
Maybe ColumnFamily
mcf <- (ChainConfig -> Maybe ColumnFamily)
-> ReaderT ChainConfig m (Maybe ColumnFamily)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChainConfig -> Maybe ColumnFamily
chainConfColumnFamily
DB
-> Maybe ColumnFamily
-> BlockHeaderKey
-> ReaderT ChainConfig m (Maybe BlockNode)
forall (m :: * -> *) key value.
(MonadIO m, KeyValue key value, Serialize key, Serialize value) =>
DB -> Maybe ColumnFamily -> key -> m (Maybe value)
retrieveCommon DB
db Maybe ColumnFamily
mcf (BlockHash -> BlockHeaderKey
BlockHeaderKey BlockHash
bh)
getBestBlockHeader :: ReaderT ChainConfig m BlockNode
getBestBlockHeader = do
DB
db <- (ChainConfig -> DB) -> ReaderT ChainConfig m DB
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChainConfig -> DB
chainConfDB
Maybe ColumnFamily
mcf <- (ChainConfig -> Maybe ColumnFamily)
-> ReaderT ChainConfig m (Maybe ColumnFamily)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChainConfig -> Maybe ColumnFamily
chainConfColumnFamily
DB
-> Maybe ColumnFamily
-> BestBlockKey
-> ReaderT ChainConfig m (Maybe BlockNode)
forall (m :: * -> *) key value.
(MonadIO m, KeyValue key value, Serialize key, Serialize value) =>
DB -> Maybe ColumnFamily -> key -> m (Maybe value)
retrieveCommon DB
db Maybe ColumnFamily
mcf BestBlockKey
BestBlockKey ReaderT ChainConfig m (Maybe BlockNode)
-> (Maybe BlockNode -> ReaderT ChainConfig m BlockNode)
-> ReaderT ChainConfig m BlockNode
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe BlockNode
Nothing -> String -> ReaderT ChainConfig m BlockNode
forall a. HasCallStack => String -> a
error String
"Could not get best block from database"
Just BlockNode
b -> BlockNode -> ReaderT ChainConfig m BlockNode
forall (m :: * -> *) a. Monad m => a -> m a
return BlockNode
b
setBestBlockHeader :: BlockNode -> ReaderT ChainConfig m ()
setBestBlockHeader BlockNode
bn = do
DB
db <- (ChainConfig -> DB) -> ReaderT ChainConfig m DB
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChainConfig -> DB
chainConfDB
(ChainConfig -> Maybe ColumnFamily)
-> ReaderT ChainConfig m (Maybe ColumnFamily)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChainConfig -> Maybe ColumnFamily
chainConfColumnFamily ReaderT ChainConfig m (Maybe ColumnFamily)
-> (Maybe ColumnFamily -> ReaderT ChainConfig m ())
-> ReaderT ChainConfig m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe ColumnFamily
Nothing -> DB -> BestBlockKey -> BlockNode -> ReaderT ChainConfig m ()
forall (m :: * -> *) key value.
(MonadIO m, KeyValue key value, Serialize key, Serialize value) =>
DB -> key -> value -> m ()
insert DB
db BestBlockKey
BestBlockKey BlockNode
bn
Just ColumnFamily
cf -> DB
-> ColumnFamily
-> BestBlockKey
-> BlockNode
-> ReaderT ChainConfig m ()
forall (m :: * -> *) key value.
(MonadIO m, KeyValue key value, Serialize key, Serialize value) =>
DB -> ColumnFamily -> key -> value -> m ()
insertCF DB
db ColumnFamily
cf BestBlockKey
BestBlockKey BlockNode
bn
addBlockHeaders :: [BlockNode] -> ReaderT ChainConfig m ()
addBlockHeaders [BlockNode]
bns = do
DB
db <- (ChainConfig -> DB) -> ReaderT ChainConfig m DB
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChainConfig -> DB
chainConfDB
Maybe ColumnFamily
mcf <- (ChainConfig -> Maybe ColumnFamily)
-> ReaderT ChainConfig m (Maybe ColumnFamily)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChainConfig -> Maybe ColumnFamily
chainConfColumnFamily
DB -> [BatchOp] -> ReaderT ChainConfig m ()
forall (m :: * -> *). MonadIO m => DB -> [BatchOp] -> m ()
writeBatch DB
db ((BlockNode -> BatchOp) -> [BlockNode] -> [BatchOp]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe ColumnFamily -> BlockNode -> BatchOp
f Maybe ColumnFamily
mcf) [BlockNode]
bns)
where
h :: BlockNode -> BlockHash
h BlockNode
bn = BlockHeader -> BlockHash
headerHash (BlockNode -> BlockHeader
nodeHeader BlockNode
bn)
f :: Maybe ColumnFamily -> BlockNode -> BatchOp
f Maybe ColumnFamily
Nothing BlockNode
bn = BlockHeaderKey -> BlockNode -> BatchOp
forall key value.
(KeyValue key value, Serialize key, Serialize value) =>
key -> value -> BatchOp
insertOp (BlockHash -> BlockHeaderKey
BlockHeaderKey (BlockNode -> BlockHash
h BlockNode
bn)) BlockNode
bn
f (Just ColumnFamily
cf) BlockNode
bn = ColumnFamily -> BlockHeaderKey -> BlockNode -> BatchOp
forall key value.
(KeyValue key value, Serialize key, Serialize value) =>
ColumnFamily -> key -> value -> BatchOp
insertOpCF ColumnFamily
cf (BlockHash -> BlockHeaderKey
BlockHeaderKey (BlockNode -> BlockHash
h BlockNode
bn)) BlockNode
bn
instance MonadIO m => BlockHeaders (ReaderT Chain m) where
getBlockHeader :: BlockHash -> ReaderT Chain m (Maybe BlockNode)
getBlockHeader BlockHash
bh = (Chain -> m (Maybe BlockNode)) -> ReaderT Chain m (Maybe BlockNode)
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((Chain -> m (Maybe BlockNode))
-> ReaderT Chain m (Maybe BlockNode))
-> (Chain -> m (Maybe BlockNode))
-> ReaderT Chain m (Maybe BlockNode)
forall a b. (a -> b) -> a -> b
$ BlockHash -> Chain -> m (Maybe BlockNode)
forall (m :: * -> *).
MonadIO m =>
BlockHash -> Chain -> m (Maybe BlockNode)
chainGetBlock BlockHash
bh
getBestBlockHeader :: ReaderT Chain m BlockNode
getBestBlockHeader = (Chain -> m BlockNode) -> ReaderT Chain m BlockNode
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT Chain -> m BlockNode
forall (m :: * -> *). MonadIO m => Chain -> m BlockNode
chainGetBest
addBlockHeader :: BlockNode -> ReaderT Chain m ()
addBlockHeader BlockNode
_ = ReaderT Chain m ()
forall a. HasCallStack => a
undefined
setBestBlockHeader :: BlockNode -> ReaderT Chain m ()
setBestBlockHeader BlockNode
_ = ReaderT Chain m ()
forall a. HasCallStack => a
undefined
addBlockHeaders :: [BlockNode] -> ReaderT Chain m ()
addBlockHeaders [BlockNode]
_ = ReaderT Chain m ()
forall a. HasCallStack => a
undefined
withBlockHeaders :: MonadChain m => ReaderT ChainConfig m a -> m a
ReaderT ChainConfig m a
f = do
ChainConfig
cfg <- (ChainReader -> ChainConfig) -> m ChainConfig
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChainReader -> ChainConfig
myConfig
ReaderT ChainConfig m a -> ChainConfig -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT ChainConfig m a
f ChainConfig
cfg
withChain ::
(MonadUnliftIO m, MonadLoggerIO m)
=> ChainConfig
-> (Chain -> m a)
-> m a
withChain :: forall (m :: * -> *) a.
(MonadUnliftIO m, MonadLoggerIO m) =>
ChainConfig -> (Chain -> m a) -> m a
withChain ChainConfig
cfg Chain -> m a
action = do
(Inbox ChainMessage
inbox, Mailbox ChainMessage
mailbox) <- m (Inbox ChainMessage, Mailbox ChainMessage)
forall (m :: * -> *) msg.
MonadUnliftIO m =>
m (Inbox msg, Mailbox msg)
newMailbox
$(logDebugS) Text
"Chain" Text
"Starting chain actor"
TVar ChainState
st <- ChainState -> m (TVar ChainState)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO ChainState :: Maybe ChainSync -> [Peer] -> Bool -> ChainState
ChainState { chainSyncing :: Maybe ChainSync
chainSyncing = Maybe ChainSync
forall a. Maybe a
Nothing
, mySynced :: Bool
mySynced = Bool
False
, newPeers :: [Peer]
newPeers = []
}
let rd :: ChainReader
rd = ChainReader :: ChainConfig -> TVar ChainState -> ChainReader
ChainReader { myConfig :: ChainConfig
myConfig = ChainConfig
cfg
, chainState :: TVar ChainState
chainState = TVar ChainState
st
}
ch :: Chain
ch = Chain :: Mailbox ChainMessage -> ChainReader -> Chain
Chain { chainReader :: ChainReader
chainReader = ChainReader
rd
, chainMailbox :: Mailbox ChainMessage
chainMailbox = Mailbox ChainMessage
mailbox
}
ReaderT ChainReader m () -> ChainReader -> m ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT ChainReader m ()
forall (m :: * -> *). MonadChain m => m ()
initChainDB ChainReader
rd
m Any -> (Async Any -> m a) -> m a
forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> (Async a -> m b) -> m b
withAsync (Chain -> ChainReader -> Inbox ChainMessage -> m Any
forall {m :: * -> *} {mbox :: * -> *} {a}.
(MonadLoggerIO m, MonadUnliftIO m, InChan mbox) =>
Chain -> ChainReader -> mbox ChainMessage -> m a
main_loop Chain
ch ChainReader
rd Inbox ChainMessage
inbox) ((Async Any -> m a) -> m a) -> (Async Any -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \Async Any
a ->
Async Any -> m ()
forall (m :: * -> *) a. MonadIO m => Async a -> m ()
link Async Any
a m () -> m a -> m a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Chain -> m a
action Chain
ch
where
main_loop :: Chain -> ChainReader -> mbox ChainMessage -> m a
main_loop Chain
ch ChainReader
rd mbox ChainMessage
inbox = Chain -> m a -> m a
forall (m :: * -> *) a.
(MonadUnliftIO m, MonadLoggerIO m) =>
Chain -> m a -> m a
withSyncLoop Chain
ch (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$
ReaderT ChainReader m a -> ChainReader -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (mbox ChainMessage -> ReaderT ChainReader m a
forall {m :: * -> *} {mbox :: * -> *} {b}.
(MonadLoggerIO m, MonadUnliftIO m, MonadReader ChainReader m,
InChan mbox) =>
mbox ChainMessage -> m b
run mbox ChainMessage
inbox) ChainReader
rd
run :: mbox ChainMessage -> m b
run mbox ChainMessage
inbox = do
ReaderT ChainConfig m BlockNode -> m BlockNode
forall (m :: * -> *) a.
MonadChain m =>
ReaderT ChainConfig m a -> m a
withBlockHeaders ReaderT ChainConfig m BlockNode
forall (m :: * -> *). BlockHeaders m => m BlockNode
getBestBlockHeader m BlockNode -> (BlockNode -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
ChainEvent -> m ()
forall (m :: * -> *). MonadChain m => ChainEvent -> m ()
chainEvent (ChainEvent -> m ())
-> (BlockNode -> ChainEvent) -> BlockNode -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockNode -> ChainEvent
ChainBestBlock
m () -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (m () -> m b) -> m () -> m b
forall a b. (a -> b) -> a -> b
$ do
ChainMessage
msg <- mbox ChainMessage -> m ChainMessage
forall (mbox :: * -> *) (m :: * -> *) msg.
(InChan mbox, MonadIO m) =>
mbox msg -> m msg
receive mbox ChainMessage
inbox
ChainMessage -> m ()
forall (m :: * -> *). MonadChain m => ChainMessage -> m ()
chainMessage ChainMessage
msg
chainEvent :: MonadChain m => ChainEvent -> m ()
chainEvent :: forall (m :: * -> *). MonadChain m => ChainEvent -> m ()
chainEvent ChainEvent
e = do
Publisher ChainEvent
pub <- (ChainReader -> Publisher ChainEvent) -> m (Publisher ChainEvent)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ChainConfig -> Publisher ChainEvent
chainConfEvents (ChainConfig -> Publisher ChainEvent)
-> (ChainReader -> ChainConfig)
-> ChainReader
-> Publisher ChainEvent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainReader -> ChainConfig
myConfig)
case ChainEvent
e of
ChainBestBlock BlockNode
b ->
$(logInfoS) Text
"Chain" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
Text
"Best block header at height: "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (Word32 -> String
forall a. Show a => a -> String
show (BlockNode -> Word32
nodeHeight BlockNode
b))
ChainSynced BlockNode
b ->
$(logInfoS) Text
"Chain" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
Text
"Headers in sync at height: "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (Word32 -> String
forall a. Show a => a -> String
show (BlockNode -> Word32
nodeHeight BlockNode
b))
ChainEvent -> Publisher ChainEvent -> m ()
forall (m :: * -> *) msg. MonadIO m => msg -> Publisher msg -> m ()
publish ChainEvent
e Publisher ChainEvent
pub
processHeaders :: MonadChain m => Peer -> [BlockHeader] -> m ()
Peer
p [BlockHeader]
hs = do
$(logDebugS) Text
"Chain" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
Text
"Processing " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (Int -> String
forall a. Show a => a -> String
show ([BlockHeader] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BlockHeader]
hs))
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" headers from peer: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
Network
net <- (ChainReader -> Network) -> m Network
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ChainConfig -> Network
chainConfNetwork (ChainConfig -> Network)
-> (ChainReader -> ChainConfig) -> ChainReader -> Network
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainReader -> ChainConfig
myConfig)
UTCTime
now <- IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
BlockNode
pbest <- ReaderT ChainConfig m BlockNode -> m BlockNode
forall (m :: * -> *) a.
MonadChain m =>
ReaderT ChainConfig m a -> m a
withBlockHeaders ReaderT ChainConfig m BlockNode
forall (m :: * -> *). BlockHeaders m => m BlockNode
getBestBlockHeader
Network
-> UTCTime -> [BlockHeader] -> m (Either PeerException Bool)
forall (m :: * -> *).
MonadChain m =>
Network
-> UTCTime -> [BlockHeader] -> m (Either PeerException Bool)
importHeaders Network
net UTCTime
now [BlockHeader]
hs m (Either PeerException Bool)
-> (Either PeerException Bool -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left PeerException
e -> do
$(logErrorS) Text
"Chain" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
Text
"Could not connect headers from peer: "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
PeerException
e PeerException -> Peer -> m ()
forall (m :: * -> *). MonadIO m => PeerException -> Peer -> m ()
`killPeer` Peer
p
Right Bool
done -> do
m ()
forall (m :: * -> *). MonadChain m => m ()
setLastReceived
BlockNode
best <- ReaderT ChainConfig m BlockNode -> m BlockNode
forall (m :: * -> *) a.
MonadChain m =>
ReaderT ChainConfig m a -> m a
withBlockHeaders ReaderT ChainConfig m BlockNode
forall (m :: * -> *). BlockHeaders m => m BlockNode
getBestBlockHeader
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BlockNode -> BlockHeader
nodeHeader BlockNode
pbest BlockHeader -> BlockHeader -> Bool
forall a. Eq a => a -> a -> Bool
/= BlockNode -> BlockHeader
nodeHeader BlockNode
best) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
ChainEvent -> m ()
forall (m :: * -> *). MonadChain m => ChainEvent -> m ()
chainEvent (BlockNode -> ChainEvent
ChainBestBlock BlockNode
best)
if Bool
done
then do
Message
MSendHeaders Message -> Peer -> m ()
forall (m :: * -> *). MonadIO m => Message -> Peer -> m ()
`sendMessage` Peer
p
Peer -> m ()
forall (m :: * -> *). MonadChain m => Peer -> m ()
finishPeer Peer
p
m ()
forall (m :: * -> *). MonadChain m => m ()
syncNewPeer
m ()
forall (m :: * -> *). MonadChain m => m ()
syncNotif
else Peer -> m ()
forall (m :: * -> *). MonadChain m => Peer -> m ()
syncPeer Peer
p
syncNewPeer :: MonadChain m => m ()
syncNewPeer :: forall (m :: * -> *). MonadChain m => m ()
syncNewPeer = m (Maybe Peer)
forall (m :: * -> *). MonadChain m => m (Maybe Peer)
getSyncingPeer m (Maybe Peer) -> (Maybe Peer -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just Peer
_ -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Maybe Peer
Nothing -> m (Maybe Peer)
forall (m :: * -> *). MonadChain m => m (Maybe Peer)
nextPeer m (Maybe Peer) -> (Maybe Peer -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe Peer
Nothing -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Peer
p -> do
$(logDebugS) Text
"Chain" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
Text
"Syncing against peer: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
Peer -> m ()
forall (m :: * -> *). MonadChain m => Peer -> m ()
syncPeer Peer
p
syncNotif :: MonadChain m => m ()
syncNotif :: forall (m :: * -> *). MonadChain m => m ()
syncNotif =
m Bool
forall (m :: * -> *). MonadChain m => m Bool
notifySynced m Bool -> (Bool -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
False -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Bool
True -> ReaderT ChainConfig m BlockNode -> m BlockNode
forall (m :: * -> *) a.
MonadChain m =>
ReaderT ChainConfig m a -> m a
withBlockHeaders ReaderT ChainConfig m BlockNode
forall (m :: * -> *). BlockHeaders m => m BlockNode
getBestBlockHeader m BlockNode -> (BlockNode -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
ChainEvent -> m ()
forall (m :: * -> *). MonadChain m => ChainEvent -> m ()
chainEvent (ChainEvent -> m ())
-> (BlockNode -> ChainEvent) -> BlockNode -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockNode -> ChainEvent
ChainSynced
syncPeer :: MonadChain m => Peer -> m ()
syncPeer :: forall (m :: * -> *). MonadChain m => Peer -> m ()
syncPeer Peer
p = do
UTCTime
t <- IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
Maybe GetHeaders
m <- m (Maybe ChainSync)
forall (m :: * -> *). MonadChain m => m (Maybe ChainSync)
chainSyncingPeer m (Maybe ChainSync)
-> (Maybe ChainSync -> m (Maybe GetHeaders))
-> m (Maybe GetHeaders)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just ChainSync { chainSyncPeer :: ChainSync -> Peer
chainSyncPeer = Peer
s
, chainHighest :: ChainSync -> Maybe BlockNode
chainHighest = Maybe BlockNode
m
}
| Peer
p Peer -> Peer -> Bool
forall a. Eq a => a -> a -> Bool
== Peer
s -> UTCTime -> Maybe BlockNode -> m (Maybe GetHeaders)
forall {m :: * -> *}.
(MonadLoggerIO m, MonadUnliftIO m, MonadReader ChainReader m) =>
UTCTime -> Maybe BlockNode -> m (Maybe GetHeaders)
syncing_me UTCTime
t Maybe BlockNode
m
| Bool
otherwise -> Maybe GetHeaders -> m (Maybe GetHeaders)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe GetHeaders
forall a. Maybe a
Nothing
Maybe ChainSync
Nothing -> UTCTime -> m (Maybe GetHeaders)
forall {m :: * -> *}.
(MonadLoggerIO m, MonadUnliftIO m, MonadReader ChainReader m) =>
UTCTime -> m (Maybe GetHeaders)
syncing_new UTCTime
t
Maybe GetHeaders -> (GetHeaders -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe GetHeaders
m ((GetHeaders -> m ()) -> m ()) -> (GetHeaders -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \GetHeaders
g -> do
$(logDebugS) Text
"Chain" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
Text
"Requesting headers from peer: "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
GetHeaders -> Message
MGetHeaders GetHeaders
g Message -> Peer -> m ()
forall (m :: * -> *). MonadIO m => Message -> Peer -> m ()
`sendMessage` Peer
p
where
syncing_new :: UTCTime -> m (Maybe GetHeaders)
syncing_new UTCTime
t =
Peer -> m Bool
forall (m :: * -> *). MonadChain m => Peer -> m Bool
setSyncingPeer Peer
p m Bool -> (Bool -> m (Maybe GetHeaders)) -> m (Maybe GetHeaders)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
False -> Maybe GetHeaders -> m (Maybe GetHeaders)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe GetHeaders
forall a. Maybe a
Nothing
Bool
True -> do
$(logDebugS) Text
"Chain" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
Text
"Locked peer: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
BlockNode
h <- ReaderT ChainConfig m BlockNode -> m BlockNode
forall (m :: * -> *) a.
MonadChain m =>
ReaderT ChainConfig m a -> m a
withBlockHeaders ReaderT ChainConfig m BlockNode
forall (m :: * -> *). BlockHeaders m => m BlockNode
getBestBlockHeader
GetHeaders -> Maybe GetHeaders
forall a. a -> Maybe a
Just (GetHeaders -> Maybe GetHeaders)
-> m GetHeaders -> m (Maybe GetHeaders)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTCTime -> BlockNode -> Peer -> m GetHeaders
forall (m :: * -> *).
MonadChain m =>
UTCTime -> BlockNode -> Peer -> m GetHeaders
syncHeaders UTCTime
t BlockNode
h Peer
p
syncing_me :: UTCTime -> Maybe BlockNode -> m (Maybe GetHeaders)
syncing_me UTCTime
t Maybe BlockNode
m = do
BlockNode
h <- case Maybe BlockNode
m of
Maybe BlockNode
Nothing -> ReaderT ChainConfig m BlockNode -> m BlockNode
forall (m :: * -> *) a.
MonadChain m =>
ReaderT ChainConfig m a -> m a
withBlockHeaders ReaderT ChainConfig m BlockNode
forall (m :: * -> *). BlockHeaders m => m BlockNode
getBestBlockHeader
Just BlockNode
h -> BlockNode -> m BlockNode
forall (m :: * -> *) a. Monad m => a -> m a
return BlockNode
h
GetHeaders -> Maybe GetHeaders
forall a. a -> Maybe a
Just (GetHeaders -> Maybe GetHeaders)
-> m GetHeaders -> m (Maybe GetHeaders)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTCTime -> BlockNode -> Peer -> m GetHeaders
forall (m :: * -> *).
MonadChain m =>
UTCTime -> BlockNode -> Peer -> m GetHeaders
syncHeaders UTCTime
t BlockNode
h Peer
p
chainMessage :: MonadChain m => ChainMessage -> m ()
chainMessage :: forall (m :: * -> *). MonadChain m => ChainMessage -> m ()
chainMessage (ChainHeaders Peer
p [BlockHeader]
hs) =
Peer -> [BlockHeader] -> m ()
forall (m :: * -> *). MonadChain m => Peer -> [BlockHeader] -> m ()
processHeaders Peer
p [BlockHeader]
hs
chainMessage (ChainPeerConnected Peer
p) = do
$(logDebugS) Text
"Chain" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Peer connected: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
Peer -> m ()
forall (m :: * -> *). MonadChain m => Peer -> m ()
addPeer Peer
p
m ()
forall (m :: * -> *). MonadChain m => m ()
syncNewPeer
chainMessage (ChainPeerDisconnected Peer
p) = do
$(logDebugS) Text
"Chain" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Peer disconnected: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
Peer -> m ()
forall (m :: * -> *). MonadChain m => Peer -> m ()
finishPeer Peer
p
m ()
forall (m :: * -> *). MonadChain m => m ()
syncNewPeer
chainMessage ChainMessage
ChainPing = do
NominalDiffTime
to <- (ChainReader -> NominalDiffTime) -> m NominalDiffTime
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ChainConfig -> NominalDiffTime
chainConfTimeout (ChainConfig -> NominalDiffTime)
-> (ChainReader -> ChainConfig) -> ChainReader -> NominalDiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainReader -> ChainConfig
myConfig)
UTCTime
now <- IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
m (Maybe ChainSync)
forall (m :: * -> *). MonadChain m => m (Maybe ChainSync)
chainSyncingPeer m (Maybe ChainSync) -> (Maybe ChainSync -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just ChainSync {chainSyncPeer :: ChainSync -> Peer
chainSyncPeer = Peer
p, chainTimestamp :: ChainSync -> UTCTime
chainTimestamp = UTCTime
t}
| UTCTime
now UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` UTCTime
t NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
> NominalDiffTime
to -> do
$(logErrorS) Text
"Chain" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
Text
"Syncing peer timed out: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
PeerException
PeerTimeout PeerException -> Peer -> m ()
forall (m :: * -> *). MonadIO m => PeerException -> Peer -> m ()
`killPeer` Peer
p
| Bool
otherwise -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Maybe ChainSync
Nothing -> m ()
forall (m :: * -> *). MonadChain m => m ()
syncNewPeer
withSyncLoop :: (MonadUnliftIO m, MonadLoggerIO m)
=> Chain -> m a -> m a
withSyncLoop :: forall (m :: * -> *) a.
(MonadUnliftIO m, MonadLoggerIO m) =>
Chain -> m a -> m a
withSyncLoop Chain
ch m a
f =
m Any -> (Async Any -> m a) -> m a
forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> (Async a -> m b) -> m b
withAsync m Any
forall {b}. m b
go ((Async Any -> m a) -> m a) -> (Async Any -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \Async Any
a ->
Async Any -> m ()
forall (m :: * -> *) a. MonadIO m => Async a -> m ()
link Async Any
a m () -> m a -> m a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m a
f
where
go :: m b
go = m () -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (m () -> m b) -> m () -> m b
forall a b. (a -> b) -> a -> b
$ do
Int
delay <- IO Int -> m Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> m Int) -> IO Int -> m Int
forall a b. (a -> b) -> a -> b
$
CharPos -> IO Int
forall a (m :: * -> *). (Random a, MonadIO m) => (a, a) -> m a
randomRIO ( Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000
, Int
20 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000 )
Int -> m ()
forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay Int
delay
ChainMessage
ChainPing ChainMessage -> Mailbox ChainMessage -> m ()
forall (m :: * -> *) (mbox :: * -> *) msg.
(MonadIO m, OutChan mbox) =>
msg -> mbox msg -> m ()
`send` Chain -> Mailbox ChainMessage
chainMailbox Chain
ch
dataVersion :: Word32
dataVersion :: Word32
dataVersion = Word32
1
initChainDB :: MonadChain m => m ()
initChainDB :: forall (m :: * -> *). MonadChain m => m ()
initChainDB = do
DB
db <- (ChainReader -> DB) -> m DB
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ChainConfig -> DB
chainConfDB (ChainConfig -> DB)
-> (ChainReader -> ChainConfig) -> ChainReader -> DB
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainReader -> ChainConfig
myConfig)
Maybe ColumnFamily
mcf <- (ChainReader -> Maybe ColumnFamily) -> m (Maybe ColumnFamily)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ChainConfig -> Maybe ColumnFamily
chainConfColumnFamily (ChainConfig -> Maybe ColumnFamily)
-> (ChainReader -> ChainConfig)
-> ChainReader
-> Maybe ColumnFamily
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainReader -> ChainConfig
myConfig)
Network
net <- (ChainReader -> Network) -> m Network
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ChainConfig -> Network
chainConfNetwork (ChainConfig -> Network)
-> (ChainReader -> ChainConfig) -> ChainReader -> Network
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainReader -> ChainConfig
myConfig)
Maybe Word32
ver <- DB -> Maybe ColumnFamily -> ChainDataVersionKey -> m (Maybe Word32)
forall (m :: * -> *) key value.
(MonadIO m, KeyValue key value, Serialize key, Serialize value) =>
DB -> Maybe ColumnFamily -> key -> m (Maybe value)
retrieveCommon DB
db Maybe ColumnFamily
mcf ChainDataVersionKey
ChainDataVersionKey
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Word32
ver Maybe Word32 -> Maybe Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word32 -> Maybe Word32
forall a. a -> Maybe a
Just Word32
dataVersion) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ m [BatchOp]
forall (m :: * -> *). MonadChain m => m [BatchOp]
purgeChainDB m [BatchOp] -> ([BatchOp] -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= DB -> [BatchOp] -> m ()
forall (m :: * -> *). MonadIO m => DB -> [BatchOp] -> m ()
writeBatch DB
db
case Maybe ColumnFamily
mcf of
Maybe ColumnFamily
Nothing -> DB -> ChainDataVersionKey -> Word32 -> m ()
forall (m :: * -> *) key value.
(MonadIO m, KeyValue key value, Serialize key, Serialize value) =>
DB -> key -> value -> m ()
insert DB
db ChainDataVersionKey
ChainDataVersionKey Word32
dataVersion
Just ColumnFamily
cf -> DB -> ColumnFamily -> ChainDataVersionKey -> Word32 -> m ()
forall (m :: * -> *) key value.
(MonadIO m, KeyValue key value, Serialize key, Serialize value) =>
DB -> ColumnFamily -> key -> value -> m ()
insertCF DB
db ColumnFamily
cf ChainDataVersionKey
ChainDataVersionKey Word32
dataVersion
DB -> Maybe ColumnFamily -> BestBlockKey -> m (Maybe BlockNode)
forall (m :: * -> *) key value.
(MonadIO m, KeyValue key value, Serialize key, Serialize value) =>
DB -> Maybe ColumnFamily -> key -> m (Maybe value)
retrieveCommon DB
db Maybe ColumnFamily
mcf BestBlockKey
BestBlockKey m (Maybe BlockNode) -> (Maybe BlockNode -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Maybe BlockNode
b ->
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe BlockNode -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe BlockNode
b :: Maybe BlockNode)) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
ReaderT ChainConfig m () -> m ()
forall (m :: * -> *) a.
MonadChain m =>
ReaderT ChainConfig m a -> m a
withBlockHeaders (ReaderT ChainConfig m () -> m ())
-> ReaderT ChainConfig m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
BlockNode -> ReaderT ChainConfig m ()
forall (m :: * -> *). BlockHeaders m => BlockNode -> m ()
addBlockHeader (Network -> BlockNode
genesisNode Network
net)
BlockNode -> ReaderT ChainConfig m ()
forall (m :: * -> *). BlockHeaders m => BlockNode -> m ()
setBestBlockHeader (Network -> BlockNode
genesisNode Network
net)
purgeChainDB :: MonadChain m => m [R.BatchOp]
purgeChainDB :: forall (m :: * -> *). MonadChain m => m [BatchOp]
purgeChainDB = do
DB
db <- (ChainReader -> DB) -> m DB
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ChainConfig -> DB
chainConfDB (ChainConfig -> DB)
-> (ChainReader -> ChainConfig) -> ChainReader -> DB
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainReader -> ChainConfig
myConfig)
Maybe ColumnFamily
mcf <- (ChainReader -> Maybe ColumnFamily) -> m (Maybe ColumnFamily)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ChainConfig -> Maybe ColumnFamily
chainConfColumnFamily (ChainConfig -> Maybe ColumnFamily)
-> (ChainReader -> ChainConfig)
-> ChainReader
-> Maybe ColumnFamily
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainReader -> ChainConfig
myConfig)
DB
-> Maybe ColumnFamily -> (Iterator -> m [BatchOp]) -> m [BatchOp]
forall {m :: * -> *} {a}.
MonadUnliftIO m =>
DB -> Maybe ColumnFamily -> (Iterator -> m a) -> m a
f DB
db Maybe ColumnFamily
mcf ((Iterator -> m [BatchOp]) -> m [BatchOp])
-> (Iterator -> m [BatchOp]) -> m [BatchOp]
forall a b. (a -> b) -> a -> b
$ \Iterator
it -> do
Iterator -> ByteString -> m ()
forall (m :: * -> *). MonadIO m => Iterator -> ByteString -> m ()
R.iterSeek Iterator
it (ByteString -> m ()) -> ByteString -> m ()
forall a b. (a -> b) -> a -> b
$ Word8 -> ByteString
B.singleton Word8
0x90
Iterator -> DB -> Maybe ColumnFamily -> m [BatchOp]
forall {m :: * -> *}.
MonadIO m =>
Iterator -> DB -> Maybe ColumnFamily -> m [BatchOp]
recurse_delete Iterator
it DB
db Maybe ColumnFamily
mcf
where
f :: DB -> Maybe ColumnFamily -> (Iterator -> m a) -> m a
f DB
db Maybe ColumnFamily
Nothing = DB -> (Iterator -> m a) -> m a
forall (m :: * -> *) a.
MonadUnliftIO m =>
DB -> (Iterator -> m a) -> m a
R.withIter DB
db
f DB
db (Just ColumnFamily
cf) = DB -> ColumnFamily -> (Iterator -> m a) -> m a
forall (m :: * -> *) a.
MonadUnliftIO m =>
DB -> ColumnFamily -> (Iterator -> m a) -> m a
R.withIterCF DB
db ColumnFamily
cf
recurse_delete :: Iterator -> DB -> Maybe ColumnFamily -> m [BatchOp]
recurse_delete Iterator
it DB
db Maybe ColumnFamily
mcf =
Iterator -> m (Maybe ByteString)
forall (m :: * -> *). MonadIO m => Iterator -> m (Maybe ByteString)
R.iterKey Iterator
it m (Maybe ByteString)
-> (Maybe ByteString -> m [BatchOp]) -> m [BatchOp]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just ByteString
k
| ByteString -> Word8
B.head ByteString
k Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x90 Bool -> Bool -> Bool
|| ByteString -> Word8
B.head ByteString
k Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x91 -> do
case Maybe ColumnFamily
mcf of
Maybe ColumnFamily
Nothing -> DB -> ByteString -> m ()
forall (m :: * -> *). MonadIO m => DB -> ByteString -> m ()
R.delete DB
db ByteString
k
Just ColumnFamily
cf -> DB -> ColumnFamily -> ByteString -> m ()
forall (m :: * -> *).
MonadIO m =>
DB -> ColumnFamily -> ByteString -> m ()
R.deleteCF DB
db ColumnFamily
cf ByteString
k
Iterator -> m ()
forall (m :: * -> *). MonadIO m => Iterator -> m ()
R.iterNext Iterator
it
(ByteString -> BatchOp
R.Del ByteString
k BatchOp -> [BatchOp] -> [BatchOp]
forall a. a -> [a] -> [a]
:) ([BatchOp] -> [BatchOp]) -> m [BatchOp] -> m [BatchOp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Iterator -> DB -> Maybe ColumnFamily -> m [BatchOp]
recurse_delete Iterator
it DB
db Maybe ColumnFamily
mcf
Maybe ByteString
_ -> [BatchOp] -> m [BatchOp]
forall (m :: * -> *) a. Monad m => a -> m a
return []
importHeaders :: MonadChain m
=> Network
-> UTCTime
-> [BlockHeader]
-> m (Either PeerException Bool)
Network
net UTCTime
now [BlockHeader]
hs =
ExceptT PeerException m Bool -> m (Either PeerException Bool)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT PeerException m Bool -> m (Either PeerException Bool))
-> ExceptT PeerException m Bool -> m (Either PeerException Bool)
forall a b. (a -> b) -> a -> b
$
m (Either String [BlockNode])
-> ExceptT PeerException m (Either String [BlockNode])
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m (Either String [BlockNode])
connect ExceptT PeerException m (Either String [BlockNode])
-> (Either String [BlockNode] -> ExceptT PeerException m Bool)
-> ExceptT PeerException m Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Right [BlockNode]
_ -> do
case [BlockHeader]
hs of
[] -> () -> ExceptT PeerException m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
[BlockHeader]
_ -> do
Maybe BlockNode
bb <- m (Maybe BlockNode) -> ExceptT PeerException m (Maybe BlockNode)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m (Maybe BlockNode)
get_last
TVar ChainState
box <- (ChainReader -> TVar ChainState)
-> ExceptT PeerException m (TVar ChainState)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChainReader -> TVar ChainState
chainState
STM () -> ExceptT PeerException m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ExceptT PeerException m ())
-> ((ChainState -> ChainState) -> STM ())
-> (ChainState -> ChainState)
-> ExceptT PeerException m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar ChainState -> (ChainState -> ChainState) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar ChainState
box ((ChainState -> ChainState) -> ExceptT PeerException m ())
-> (ChainState -> ChainState) -> ExceptT PeerException m ()
forall a b. (a -> b) -> a -> b
$ \ChainState
s ->
ChainState
s { chainSyncing :: Maybe ChainSync
chainSyncing =
(\ChainSync
x -> ChainSync
x {chainHighest :: Maybe BlockNode
chainHighest = Maybe BlockNode
bb})
(ChainSync -> ChainSync) -> Maybe ChainSync -> Maybe ChainSync
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainState -> Maybe ChainSync
chainSyncing ChainState
s
}
case [BlockHeader] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BlockHeader]
hs of
Int
2000 -> Bool -> ExceptT PeerException m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
Int
_ -> Bool -> ExceptT PeerException m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
Left String
_ -> PeerException -> ExceptT PeerException m Bool
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError PeerException
PeerSentBadHeaders
where
timestamp :: Word32
timestamp = NominalDiffTime -> Word32
forall a b. (RealFrac a, Integral b) => a -> b
floor (UTCTime -> NominalDiffTime
utcTimeToPOSIXSeconds UTCTime
now)
connect :: m (Either String [BlockNode])
connect = ReaderT ChainConfig m (Either String [BlockNode])
-> m (Either String [BlockNode])
forall (m :: * -> *) a.
MonadChain m =>
ReaderT ChainConfig m a -> m a
withBlockHeaders (ReaderT ChainConfig m (Either String [BlockNode])
-> m (Either String [BlockNode]))
-> ReaderT ChainConfig m (Either String [BlockNode])
-> m (Either String [BlockNode])
forall a b. (a -> b) -> a -> b
$ Network
-> Word32
-> [BlockHeader]
-> ReaderT ChainConfig m (Either String [BlockNode])
forall (m :: * -> *).
BlockHeaders m =>
Network -> Word32 -> [BlockHeader] -> m (Either String [BlockNode])
connectBlocks Network
net Word32
timestamp [BlockHeader]
hs
get_last :: m (Maybe BlockNode)
get_last = ReaderT ChainConfig m (Maybe BlockNode) -> m (Maybe BlockNode)
forall (m :: * -> *) a.
MonadChain m =>
ReaderT ChainConfig m a -> m a
withBlockHeaders (ReaderT ChainConfig m (Maybe BlockNode) -> m (Maybe BlockNode))
-> (BlockHeader -> ReaderT ChainConfig m (Maybe BlockNode))
-> BlockHeader
-> m (Maybe BlockNode)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockHash -> ReaderT ChainConfig m (Maybe BlockNode)
forall (m :: * -> *).
BlockHeaders m =>
BlockHash -> m (Maybe BlockNode)
getBlockHeader (BlockHash -> ReaderT ChainConfig m (Maybe BlockNode))
-> (BlockHeader -> BlockHash)
-> BlockHeader
-> ReaderT ChainConfig m (Maybe BlockNode)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockHeader -> BlockHash
headerHash (BlockHeader -> m (Maybe BlockNode))
-> BlockHeader -> m (Maybe BlockNode)
forall a b. (a -> b) -> a -> b
$ [BlockHeader] -> BlockHeader
forall a. [a] -> a
last [BlockHeader]
hs
notifySynced :: MonadChain m => m Bool
notifySynced :: forall (m :: * -> *). MonadChain m => m Bool
notifySynced =
(Maybe () -> Bool) -> m (Maybe ()) -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe () -> Bool
forall a. Maybe a -> Bool
isJust (m (Maybe ()) -> m Bool) -> m (Maybe ()) -> m Bool
forall a b. (a -> b) -> a -> b
$
MaybeT m () -> m (Maybe ())
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT m () -> m (Maybe ())) -> MaybeT m () -> m (Maybe ())
forall a b. (a -> b) -> a -> b
$ do
BlockNode
bb <- m BlockNode -> MaybeT m BlockNode
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m BlockNode -> MaybeT m BlockNode)
-> m BlockNode -> MaybeT m BlockNode
forall a b. (a -> b) -> a -> b
$ ReaderT ChainConfig m BlockNode -> m BlockNode
forall (m :: * -> *) a.
MonadChain m =>
ReaderT ChainConfig m a -> m a
withBlockHeaders ReaderT ChainConfig m BlockNode
forall (m :: * -> *). BlockHeaders m => m BlockNode
getBestBlockHeader
UTCTime
now <- IO UTCTime -> MaybeT m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
Bool -> MaybeT m ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> MaybeT m ()) -> Bool -> MaybeT m ()
forall a b. (a -> b) -> a -> b
$ UTCTime
now UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` BlockNode -> UTCTime
block_time BlockNode
bb NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
> NominalDiffTime
7200
TVar ChainState
st <- (ChainReader -> TVar ChainState) -> MaybeT m (TVar ChainState)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChainReader -> TVar ChainState
chainState
m (Maybe ()) -> MaybeT m ()
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe ()) -> MaybeT m ())
-> (MaybeT STM () -> m (Maybe ())) -> MaybeT STM () -> MaybeT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM (Maybe ()) -> m (Maybe ())
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Maybe ()) -> m (Maybe ()))
-> (MaybeT STM () -> STM (Maybe ()))
-> MaybeT STM ()
-> m (Maybe ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MaybeT STM () -> STM (Maybe ())
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT STM () -> MaybeT m ()) -> MaybeT STM () -> MaybeT m ()
forall a b. (a -> b) -> a -> b
$ do
ChainState
s <- STM ChainState -> MaybeT STM ChainState
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (STM ChainState -> MaybeT STM ChainState)
-> STM ChainState -> MaybeT STM ChainState
forall a b. (a -> b) -> a -> b
$ TVar ChainState -> STM ChainState
forall a. TVar a -> STM a
readTVar TVar ChainState
st
Bool -> MaybeT STM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> MaybeT STM ())
-> (Maybe ChainSync -> Bool) -> Maybe ChainSync -> MaybeT STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe ChainSync -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe ChainSync -> MaybeT STM ())
-> Maybe ChainSync -> MaybeT STM ()
forall a b. (a -> b) -> a -> b
$ ChainState -> Maybe ChainSync
chainSyncing ChainState
s
Bool -> MaybeT STM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> MaybeT STM ())
-> ([Peer] -> Bool) -> [Peer] -> MaybeT STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Peer] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Peer] -> MaybeT STM ()) -> [Peer] -> MaybeT STM ()
forall a b. (a -> b) -> a -> b
$ ChainState -> [Peer]
newPeers ChainState
s
Bool -> MaybeT STM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> MaybeT STM ()) -> (Bool -> Bool) -> Bool -> MaybeT STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not (Bool -> MaybeT STM ()) -> Bool -> MaybeT STM ()
forall a b. (a -> b) -> a -> b
$ ChainState -> Bool
mySynced ChainState
s
STM () -> MaybeT STM ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (STM () -> MaybeT STM ()) -> STM () -> MaybeT STM ()
forall a b. (a -> b) -> a -> b
$ TVar ChainState -> ChainState -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar ChainState
st ChainState
s {mySynced :: Bool
mySynced = Bool
True}
() -> MaybeT STM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
block_time :: BlockNode -> UTCTime
block_time =
NominalDiffTime -> UTCTime
posixSecondsToUTCTime (NominalDiffTime -> UTCTime)
-> (BlockNode -> NominalDiffTime) -> BlockNode -> UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> NominalDiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> NominalDiffTime)
-> (BlockNode -> Word32) -> BlockNode -> NominalDiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockHeader -> Word32
blockTimestamp (BlockHeader -> Word32)
-> (BlockNode -> BlockHeader) -> BlockNode -> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockNode -> BlockHeader
nodeHeader
nextPeer :: MonadChain m => m (Maybe Peer)
nextPeer :: forall (m :: * -> *). MonadChain m => m (Maybe Peer)
nextPeer = do
[Peer]
ps <- ChainState -> [Peer]
newPeers (ChainState -> [Peer]) -> m ChainState -> m [Peer]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TVar ChainState -> m ChainState
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (TVar ChainState -> m ChainState)
-> m (TVar ChainState) -> m ChainState
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (ChainReader -> TVar ChainState) -> m (TVar ChainState)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChainReader -> TVar ChainState
chainState)
[Peer] -> m (Maybe Peer)
forall {m :: * -> *}.
(MonadLoggerIO m, MonadUnliftIO m, MonadReader ChainReader m) =>
[Peer] -> m (Maybe Peer)
go [Peer]
ps
where
go :: [Peer] -> m (Maybe Peer)
go [] = Maybe Peer -> m (Maybe Peer)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Peer
forall a. Maybe a
Nothing
go (Peer
p:[Peer]
ps) =
Peer -> m Bool
forall (m :: * -> *). MonadChain m => Peer -> m Bool
setSyncingPeer Peer
p m Bool -> (Bool -> m (Maybe Peer)) -> m (Maybe Peer)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
True -> Maybe Peer -> m (Maybe Peer)
forall (m :: * -> *) a. Monad m => a -> m a
return (Peer -> Maybe Peer
forall a. a -> Maybe a
Just Peer
p)
Bool
False -> [Peer] -> m (Maybe Peer)
go [Peer]
ps
syncHeaders ::
MonadChain m
=> UTCTime
-> BlockNode
-> Peer
-> m GetHeaders
UTCTime
now BlockNode
bb Peer
p = do
TVar ChainState
st <- (ChainReader -> TVar ChainState) -> m (TVar ChainState)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChainReader -> TVar ChainState
chainState
STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$
TVar ChainState -> (ChainState -> ChainState) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar ChainState
st ((ChainState -> ChainState) -> STM ())
-> (ChainState -> ChainState) -> STM ()
forall a b. (a -> b) -> a -> b
$ \ChainState
s ->
ChainState
s { chainSyncing :: Maybe ChainSync
chainSyncing =
ChainSync -> Maybe ChainSync
forall a. a -> Maybe a
Just
ChainSync :: Peer -> UTCTime -> Maybe BlockNode -> ChainSync
ChainSync
{ chainSyncPeer :: Peer
chainSyncPeer = Peer
p
, chainTimestamp :: UTCTime
chainTimestamp = UTCTime
now
, chainHighest :: Maybe BlockNode
chainHighest = Maybe BlockNode
forall a. Maybe a
Nothing
}
, newPeers :: [Peer]
newPeers = Peer -> [Peer] -> [Peer]
forall a. Eq a => a -> [a] -> [a]
delete Peer
p (ChainState -> [Peer]
newPeers ChainState
s)
}
BlockLocator
loc <- ReaderT ChainConfig m BlockLocator -> m BlockLocator
forall (m :: * -> *) a.
MonadChain m =>
ReaderT ChainConfig m a -> m a
withBlockHeaders (ReaderT ChainConfig m BlockLocator -> m BlockLocator)
-> ReaderT ChainConfig m BlockLocator -> m BlockLocator
forall a b. (a -> b) -> a -> b
$ BlockNode -> ReaderT ChainConfig m BlockLocator
forall (m :: * -> *). BlockHeaders m => BlockNode -> m BlockLocator
blockLocator BlockNode
bb
GetHeaders -> m GetHeaders
forall (m :: * -> *) a. Monad m => a -> m a
return
GetHeaders :: Word32 -> BlockLocator -> BlockHash -> GetHeaders
GetHeaders
{ getHeadersVersion :: Word32
getHeadersVersion = Word32
myVersion
, getHeadersBL :: BlockLocator
getHeadersBL = BlockLocator
loc
, getHeadersHashStop :: BlockHash
getHeadersHashStop = BlockHash
z
}
where
z :: BlockHash
z = BlockHash
"0000000000000000000000000000000000000000000000000000000000000000"
setLastReceived :: MonadChain m => m ()
setLastReceived :: forall (m :: * -> *). MonadChain m => m ()
setLastReceived = do
UTCTime
now <- IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
TVar ChainState
st <- (ChainReader -> TVar ChainState) -> m (TVar ChainState)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChainReader -> TVar ChainState
chainState
let f :: ChainSync -> ChainSync
f ChainSync
p = ChainSync
p { chainTimestamp :: UTCTime
chainTimestamp = UTCTime
now }
STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ())
-> ((ChainState -> ChainState) -> STM ())
-> (ChainState -> ChainState)
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar ChainState -> (ChainState -> ChainState) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar ChainState
st ((ChainState -> ChainState) -> m ())
-> (ChainState -> ChainState) -> m ()
forall a b. (a -> b) -> a -> b
$ \ChainState
s ->
ChainState
s { chainSyncing :: Maybe ChainSync
chainSyncing = ChainSync -> ChainSync
f (ChainSync -> ChainSync) -> Maybe ChainSync -> Maybe ChainSync
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainState -> Maybe ChainSync
chainSyncing ChainState
s }
addPeer :: MonadChain m => Peer -> m ()
addPeer :: forall (m :: * -> *). MonadChain m => Peer -> m ()
addPeer Peer
p = do
TVar ChainState
st <- (ChainReader -> TVar ChainState) -> m (TVar ChainState)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChainReader -> TVar ChainState
chainState
STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ())
-> ((ChainState -> ChainState) -> STM ())
-> (ChainState -> ChainState)
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar ChainState -> (ChainState -> ChainState) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar ChainState
st ((ChainState -> ChainState) -> m ())
-> (ChainState -> ChainState) -> m ()
forall a b. (a -> b) -> a -> b
$ \ChainState
s -> ChainState
s {newPeers :: [Peer]
newPeers = [Peer] -> [Peer]
forall a. Eq a => [a] -> [a]
nub (Peer
p Peer -> [Peer] -> [Peer]
forall a. a -> [a] -> [a]
: ChainState -> [Peer]
newPeers ChainState
s)}
getSyncingPeer :: MonadChain m => m (Maybe Peer)
getSyncingPeer :: forall (m :: * -> *). MonadChain m => m (Maybe Peer)
getSyncingPeer =
(ChainSync -> Peer) -> Maybe ChainSync -> Maybe Peer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ChainSync -> Peer
chainSyncPeer (Maybe ChainSync -> Maybe Peer)
-> (ChainState -> Maybe ChainSync) -> ChainState -> Maybe Peer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainState -> Maybe ChainSync
chainSyncing (ChainState -> Maybe Peer) -> m ChainState -> m (Maybe Peer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TVar ChainState -> m ChainState
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (TVar ChainState -> m ChainState)
-> m (TVar ChainState) -> m ChainState
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (ChainReader -> TVar ChainState) -> m (TVar ChainState)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChainReader -> TVar ChainState
chainState)
setSyncingPeer :: MonadChain m => Peer -> m Bool
setSyncingPeer :: forall (m :: * -> *). MonadChain m => Peer -> m Bool
setSyncingPeer Peer
p =
Peer -> m Bool
forall (m :: * -> *). MonadIO m => Peer -> m Bool
setBusy Peer
p m Bool -> (Bool -> m Bool) -> m Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
False -> do
$(logDebugS) Text
"Chain" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
Text
"Could not lock peer: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
Bool
True -> do
$(logDebugS) Text
"Chain" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
Text
"Locked peer: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
m ()
set_it
Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
where
set_it :: m ()
set_it = do
UTCTime
now <- IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
TVar ChainState
box <- (ChainReader -> TVar ChainState) -> m (TVar ChainState)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChainReader -> TVar ChainState
chainState
STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ TVar ChainState -> (ChainState -> ChainState) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar ChainState
box ((ChainState -> ChainState) -> STM ())
-> (ChainState -> ChainState) -> STM ()
forall a b. (a -> b) -> a -> b
$ \ChainState
s ->
ChainState
s { chainSyncing :: Maybe ChainSync
chainSyncing =
ChainSync -> Maybe ChainSync
forall a. a -> Maybe a
Just ChainSync :: Peer -> UTCTime -> Maybe BlockNode -> ChainSync
ChainSync { chainSyncPeer :: Peer
chainSyncPeer = Peer
p
, chainTimestamp :: UTCTime
chainTimestamp = UTCTime
now
, chainHighest :: Maybe BlockNode
chainHighest = Maybe BlockNode
forall a. Maybe a
Nothing
}
}
finishPeer :: MonadChain m => Peer -> m ()
finishPeer :: forall (m :: * -> *). MonadChain m => Peer -> m ()
finishPeer Peer
p =
(ChainReader -> TVar ChainState) -> m (TVar ChainState)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChainReader -> TVar ChainState
chainState m (TVar ChainState) -> (TVar ChainState -> m Bool) -> m Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TVar ChainState -> m Bool
forall {m :: * -> *}. MonadIO m => TVar ChainState -> m Bool
remove_peer m Bool -> (Bool -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
False ->
$(logDebugS) Text
"Chain" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
Text
"Removed peer from queue: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
Bool
True -> do
$(logDebugS) Text
"Chain" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
Text
"Releasing syncing peer: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
Peer -> m ()
forall (m :: * -> *). MonadIO m => Peer -> m ()
setFree Peer
p
where
remove_peer :: TVar ChainState -> m Bool
remove_peer TVar ChainState
st = STM Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Bool -> m Bool) -> STM Bool -> m Bool
forall a b. (a -> b) -> a -> b
$
TVar ChainState -> STM ChainState
forall a. TVar a -> STM a
readTVar TVar ChainState
st STM ChainState -> (ChainState -> STM Bool) -> STM Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ChainState
s -> case ChainState -> Maybe ChainSync
chainSyncing ChainState
s of
Just ChainSync { chainSyncPeer :: ChainSync -> Peer
chainSyncPeer = Peer
p' }
| Peer
p Peer -> Peer -> Bool
forall a. Eq a => a -> a -> Bool
== Peer
p' -> do
TVar ChainState -> STM ()
unset_syncing TVar ChainState
st
Bool -> STM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
Maybe ChainSync
_ -> do
TVar ChainState -> STM ()
remove_from_queue TVar ChainState
st
Bool -> STM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
unset_syncing :: TVar ChainState -> STM ()
unset_syncing TVar ChainState
st =
TVar ChainState -> (ChainState -> ChainState) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar ChainState
st ((ChainState -> ChainState) -> STM ())
-> (ChainState -> ChainState) -> STM ()
forall a b. (a -> b) -> a -> b
$ \ChainState
x ->
ChainState
x { chainSyncing :: Maybe ChainSync
chainSyncing = Maybe ChainSync
forall a. Maybe a
Nothing }
remove_from_queue :: TVar ChainState -> STM ()
remove_from_queue TVar ChainState
st =
TVar ChainState -> (ChainState -> ChainState) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar ChainState
st ((ChainState -> ChainState) -> STM ())
-> (ChainState -> ChainState) -> STM ()
forall a b. (a -> b) -> a -> b
$ \ChainState
x ->
ChainState
x { newPeers :: [Peer]
newPeers = Peer -> [Peer] -> [Peer]
forall a. Eq a => a -> [a] -> [a]
delete Peer
p (ChainState -> [Peer]
newPeers ChainState
x) }
chainSyncingPeer :: MonadChain m => m (Maybe ChainSync)
chainSyncingPeer :: forall (m :: * -> *). MonadChain m => m (Maybe ChainSync)
chainSyncingPeer =
ChainState -> Maybe ChainSync
chainSyncing (ChainState -> Maybe ChainSync)
-> m ChainState -> m (Maybe ChainSync)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TVar ChainState -> m ChainState
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (TVar ChainState -> m ChainState)
-> m (TVar ChainState) -> m ChainState
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (ChainReader -> TVar ChainState) -> m (TVar ChainState)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChainReader -> TVar ChainState
chainState)
chainGetBlock :: MonadIO m
=> BlockHash -> Chain -> m (Maybe BlockNode)
chainGetBlock :: forall (m :: * -> *).
MonadIO m =>
BlockHash -> Chain -> m (Maybe BlockNode)
chainGetBlock BlockHash
bh Chain
ch =
ReaderT ChainConfig m (Maybe BlockNode)
-> ChainConfig -> m (Maybe BlockNode)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (BlockHash -> ReaderT ChainConfig m (Maybe BlockNode)
forall (m :: * -> *).
BlockHeaders m =>
BlockHash -> m (Maybe BlockNode)
getBlockHeader BlockHash
bh) (ChainReader -> ChainConfig
myConfig (Chain -> ChainReader
chainReader Chain
ch))
chainGetBest :: MonadIO m => Chain -> m BlockNode
chainGetBest :: forall (m :: * -> *). MonadIO m => Chain -> m BlockNode
chainGetBest Chain
ch =
ReaderT ChainConfig m BlockNode -> ChainConfig -> m BlockNode
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT ChainConfig m BlockNode
forall (m :: * -> *). BlockHeaders m => m BlockNode
getBestBlockHeader (ChainReader -> ChainConfig
myConfig (Chain -> ChainReader
chainReader Chain
ch))
chainGetAncestor :: MonadIO m
=> BlockHeight
-> BlockNode
-> Chain
-> m (Maybe BlockNode)
chainGetAncestor :: forall (m :: * -> *).
MonadIO m =>
Word32 -> BlockNode -> Chain -> m (Maybe BlockNode)
chainGetAncestor Word32
h BlockNode
bn Chain
ch =
ReaderT ChainConfig m (Maybe BlockNode)
-> ChainConfig -> m (Maybe BlockNode)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Word32 -> BlockNode -> ReaderT ChainConfig m (Maybe BlockNode)
forall (m :: * -> *).
BlockHeaders m =>
Word32 -> BlockNode -> m (Maybe BlockNode)
getAncestor Word32
h BlockNode
bn) (ChainReader -> ChainConfig
myConfig (Chain -> ChainReader
chainReader Chain
ch))
chainGetParents :: MonadIO m
=> BlockHeight
-> BlockNode
-> Chain
-> m [BlockNode]
chainGetParents :: forall (m :: * -> *).
MonadIO m =>
Word32 -> BlockNode -> Chain -> m [BlockNode]
chainGetParents Word32
height BlockNode
top Chain
ch =
[BlockNode] -> BlockNode -> m [BlockNode]
forall {m :: * -> *}.
MonadIO m =>
[BlockNode] -> BlockNode -> m [BlockNode]
go [] BlockNode
top
where
go :: [BlockNode] -> BlockNode -> m [BlockNode]
go [BlockNode]
acc BlockNode
b
| Word32
height Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
>= BlockNode -> Word32
nodeHeight BlockNode
b = [BlockNode] -> m [BlockNode]
forall (m :: * -> *) a. Monad m => a -> m a
return [BlockNode]
acc
| Bool
otherwise = do
Maybe BlockNode
m <- BlockHash -> Chain -> m (Maybe BlockNode)
forall (m :: * -> *).
MonadIO m =>
BlockHash -> Chain -> m (Maybe BlockNode)
chainGetBlock (BlockHeader -> BlockHash
prevBlock (BlockHeader -> BlockHash) -> BlockHeader -> BlockHash
forall a b. (a -> b) -> a -> b
$ BlockNode -> BlockHeader
nodeHeader BlockNode
b) Chain
ch
case Maybe BlockNode
m of
Maybe BlockNode
Nothing -> [BlockNode] -> m [BlockNode]
forall (m :: * -> *) a. Monad m => a -> m a
return [BlockNode]
acc
Just BlockNode
p -> [BlockNode] -> BlockNode -> m [BlockNode]
go (BlockNode
p BlockNode -> [BlockNode] -> [BlockNode]
forall a. a -> [a] -> [a]
: [BlockNode]
acc) BlockNode
p
chainGetSplitBlock :: MonadIO m
=> BlockNode
-> BlockNode
-> Chain
-> m BlockNode
chainGetSplitBlock :: forall (m :: * -> *).
MonadIO m =>
BlockNode -> BlockNode -> Chain -> m BlockNode
chainGetSplitBlock BlockNode
l BlockNode
r Chain
ch =
ReaderT ChainConfig m BlockNode -> ChainConfig -> m BlockNode
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (BlockNode -> BlockNode -> ReaderT ChainConfig m BlockNode
forall (m :: * -> *).
BlockHeaders m =>
BlockNode -> BlockNode -> m BlockNode
splitPoint BlockNode
l BlockNode
r) (ChainReader -> ChainConfig
myConfig (Chain -> ChainReader
chainReader Chain
ch))
chainPeerConnected :: MonadIO m
=> Peer
-> Chain
-> m ()
chainPeerConnected :: forall (m :: * -> *). MonadIO m => Peer -> Chain -> m ()
chainPeerConnected Peer
p Chain
ch =
Peer -> ChainMessage
ChainPeerConnected Peer
p ChainMessage -> Mailbox ChainMessage -> m ()
forall (m :: * -> *) (mbox :: * -> *) msg.
(MonadIO m, OutChan mbox) =>
msg -> mbox msg -> m ()
`send` Chain -> Mailbox ChainMessage
chainMailbox Chain
ch
chainPeerDisconnected :: MonadIO m
=> Peer
-> Chain
-> m ()
chainPeerDisconnected :: forall (m :: * -> *). MonadIO m => Peer -> Chain -> m ()
chainPeerDisconnected Peer
p Chain
ch =
Peer -> ChainMessage
ChainPeerDisconnected Peer
p ChainMessage -> Mailbox ChainMessage -> m ()
forall (m :: * -> *) (mbox :: * -> *) msg.
(MonadIO m, OutChan mbox) =>
msg -> mbox msg -> m ()
`send` Chain -> Mailbox ChainMessage
chainMailbox Chain
ch
chainBlockMain :: MonadIO m
=> BlockHash
-> Chain
-> m Bool
chainBlockMain :: forall (m :: * -> *). MonadIO m => BlockHash -> Chain -> m Bool
chainBlockMain BlockHash
bh Chain
ch =
Chain -> m BlockNode
forall (m :: * -> *). MonadIO m => Chain -> m BlockNode
chainGetBest Chain
ch m BlockNode -> (BlockNode -> m Bool) -> m Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \BlockNode
bb ->
BlockHash -> Chain -> m (Maybe BlockNode)
forall (m :: * -> *).
MonadIO m =>
BlockHash -> Chain -> m (Maybe BlockNode)
chainGetBlock BlockHash
bh Chain
ch m (Maybe BlockNode) -> (Maybe BlockNode -> m Bool) -> m Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe BlockNode
Nothing ->
Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
bm :: Maybe BlockNode
bm@(Just BlockNode
bn) ->
(Maybe BlockNode -> Maybe BlockNode -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe BlockNode
bm) (Maybe BlockNode -> Bool) -> m (Maybe BlockNode) -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word32 -> BlockNode -> Chain -> m (Maybe BlockNode)
forall (m :: * -> *).
MonadIO m =>
Word32 -> BlockNode -> Chain -> m (Maybe BlockNode)
chainGetAncestor (BlockNode -> Word32
nodeHeight BlockNode
bn) BlockNode
bb Chain
ch
chainIsSynced :: MonadIO m => Chain -> m Bool
chainIsSynced :: forall (m :: * -> *). MonadIO m => Chain -> m Bool
chainIsSynced Chain
ch =
ChainState -> Bool
mySynced (ChainState -> Bool) -> m ChainState -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar ChainState -> m ChainState
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (ChainReader -> TVar ChainState
chainState (Chain -> ChainReader
chainReader Chain
ch))
chainHeaders :: MonadIO m
=> Peer -> [BlockHeader] -> Chain -> m ()
Peer
p [BlockHeader]
hs Chain
ch =
Peer -> [BlockHeader] -> ChainMessage
ChainHeaders Peer
p [BlockHeader]
hs ChainMessage -> Mailbox ChainMessage -> m ()
forall (m :: * -> *) (mbox :: * -> *) msg.
(MonadIO m, OutChan mbox) =>
msg -> mbox msg -> m ()
`send` Chain -> Mailbox ChainMessage
chainMailbox Chain
ch