{-# 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
$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)
}
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
== 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
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
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 ()
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
dataVersion :: Word32
dataVersion :: Word32
dataVersion = 1
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)
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 []
importHeaders :: MonadChain m
=> Network
-> UTCTime
-> [BlockHeader]
-> m (Either PeerException Bool)
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
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
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
syncHeaders ::
MonadChain m
=> UTCTime
-> BlockNode
-> Peer
-> m GetHeaders
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"
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 }
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)}
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
}
}
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) }
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)
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))
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))
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))
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
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))
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
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
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
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))
chainHeaders :: MonadIO m
=> Peer -> [BlockHeader] -> Chain -> m ()
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