{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoFieldSelectors #-}
{-# 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.Peer
import Haskoin.Node.PeerMgr (myVersion)
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
mailbox :: !(Mailbox ChainMessage),
Chain -> ChainReader
reader :: !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` (.mailbox)
data ChainConfig = ChainConfig
{
ChainConfig -> DB
db :: !DB,
ChainConfig -> Maybe ColumnFamily
cf :: !(Maybe ColumnFamily),
ChainConfig -> Network
net :: !Network,
ChainConfig -> Publisher ChainEvent
pub :: !(Publisher ChainEvent),
ChainConfig -> NominalDiffTime
timeout :: !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
$c== :: ChainEvent -> ChainEvent -> Bool
== :: ChainEvent -> ChainEvent -> Bool
$c/= :: ChainEvent -> ChainEvent -> Bool
/= :: 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
$cshowsPrec :: Int -> ChainEvent -> ShowS
showsPrec :: Int -> ChainEvent -> ShowS
$cshow :: ChainEvent -> String
show :: ChainEvent -> String
$cshowList :: [ChainEvent] -> ShowS
showList :: [ChainEvent] -> ShowS
Show)
type MonadChain m =
( MonadLoggerIO m,
MonadUnliftIO m,
MonadReader ChainReader m
)
data ChainReader = ChainReader
{
ChainReader -> ChainConfig
config :: !ChainConfig,
ChainReader -> TVar ChainState
state :: !(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
$c== :: ChainDataVersionKey -> ChainDataVersionKey -> Bool
== :: ChainDataVersionKey -> ChainDataVersionKey -> Bool
$c/= :: ChainDataVersionKey -> ChainDataVersionKey -> Bool
/= :: 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
$ccompare :: ChainDataVersionKey -> ChainDataVersionKey -> Ordering
compare :: ChainDataVersionKey -> ChainDataVersionKey -> Ordering
$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
>= :: ChainDataVersionKey -> ChainDataVersionKey -> Bool
$cmax :: ChainDataVersionKey -> ChainDataVersionKey -> ChainDataVersionKey
max :: ChainDataVersionKey -> ChainDataVersionKey -> ChainDataVersionKey
$cmin :: ChainDataVersionKey -> ChainDataVersionKey -> ChainDataVersionKey
min :: ChainDataVersionKey -> ChainDataVersionKey -> 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
$cshowsPrec :: Int -> ChainDataVersionKey -> ShowS
showsPrec :: Int -> ChainDataVersionKey -> ShowS
$cshow :: ChainDataVersionKey -> String
show :: ChainDataVersionKey -> String
$cshowList :: [ChainDataVersionKey] -> ShowS
showList :: [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 a. a -> Get a
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
peer :: !Peer,
ChainSync -> UTCTime
timestamp :: !UTCTime,
ChainSync -> Maybe BlockNode
best :: !(Maybe BlockNode)
}
data ChainState = ChainState
{
ChainState -> Maybe ChainSync
syncing :: !(Maybe ChainSync),
ChainState -> [Peer]
peers :: ![Peer],
ChainState -> Bool
beenInSync :: !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
$c== :: BlockHeaderKey -> BlockHeaderKey -> Bool
== :: BlockHeaderKey -> BlockHeaderKey -> Bool
$c/= :: BlockHeaderKey -> BlockHeaderKey -> Bool
/= :: 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
$cshowsPrec :: Int -> BlockHeaderKey -> ShowS
showsPrec :: Int -> BlockHeaderKey -> ShowS
$cshow :: BlockHeaderKey -> String
show :: BlockHeaderKey -> String
$cshowList :: [BlockHeaderKey] -> ShowS
showList :: [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
$c== :: BestBlockKey -> BestBlockKey -> Bool
== :: BestBlockKey -> BestBlockKey -> Bool
$c/= :: BestBlockKey -> BestBlockKey -> Bool
/= :: 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
$cshowsPrec :: Int -> BestBlockKey -> ShowS
showsPrec :: Int -> BestBlockKey -> ShowS
$cshow :: BestBlockKey -> String
show :: BestBlockKey -> String
$cshowList :: [BestBlockKey] -> ShowS
showList :: [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 a. a -> Get a
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 (.db)
(ChainConfig -> Maybe ColumnFamily)
-> ReaderT ChainConfig m (Maybe ColumnFamily)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.cf) ReaderT ChainConfig m (Maybe ColumnFamily)
-> (Maybe ColumnFamily -> ReaderT ChainConfig m ())
-> ReaderT ChainConfig m ()
forall a b.
ReaderT ChainConfig m a
-> (a -> ReaderT ChainConfig m b) -> ReaderT ChainConfig m b
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
bn.header
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 (.db)
Maybe ColumnFamily
mcf <- (ChainConfig -> Maybe ColumnFamily)
-> ReaderT ChainConfig m (Maybe ColumnFamily)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.cf)
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 (.db)
Maybe ColumnFamily
mcf <- (ChainConfig -> Maybe ColumnFamily)
-> ReaderT ChainConfig m (Maybe ColumnFamily)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.cf)
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 a b.
ReaderT ChainConfig m a
-> (a -> ReaderT ChainConfig m b) -> ReaderT ChainConfig m b
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 a. a -> ReaderT ChainConfig m a
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 (.db)
(ChainConfig -> Maybe ColumnFamily)
-> ReaderT ChainConfig m (Maybe ColumnFamily)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.cf) ReaderT ChainConfig m (Maybe ColumnFamily)
-> (Maybe ColumnFamily -> ReaderT ChainConfig m ())
-> ReaderT ChainConfig m ()
forall a b.
ReaderT ChainConfig m a
-> (a -> ReaderT ChainConfig m b) -> ReaderT ChainConfig m b
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 (.db)
Maybe ColumnFamily
mcf <- (ChainConfig -> Maybe ColumnFamily)
-> ReaderT ChainConfig m (Maybe ColumnFamily)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.cf)
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
forall {value}.
(KeyValue BlockHeaderKey value, Serialize value,
HasField "header" value BlockHeader) =>
Maybe ColumnFamily -> value -> BatchOp
f Maybe ColumnFamily
mcf) [BlockNode]
bns)
where
h :: r -> BlockHash
h r
bn = BlockHeader -> BlockHash
headerHash r
bn.header
f :: Maybe ColumnFamily -> value -> BatchOp
f Maybe ColumnFamily
Nothing value
bn = BlockHeaderKey -> value -> BatchOp
forall key value.
(KeyValue key value, Serialize key, Serialize value) =>
key -> value -> BatchOp
insertOp (BlockHash -> BlockHeaderKey
BlockHeaderKey (value -> BlockHash
forall {r}. HasField "header" r BlockHeader => r -> BlockHash
h value
bn)) value
bn
f (Just ColumnFamily
cf) value
bn = ColumnFamily -> BlockHeaderKey -> value -> BatchOp
forall key value.
(KeyValue key value, Serialize key, Serialize value) =>
ColumnFamily -> key -> value -> BatchOp
insertOpCF ColumnFamily
cf (BlockHash -> BlockHeaderKey
BlockHeaderKey (value -> BlockHash
forall {r}. HasField "header" r BlockHeader => r -> BlockHash
h value
bn)) value
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 (.config)
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
{ $sel:syncing:ChainState :: Maybe ChainSync
syncing = Maybe ChainSync
forall a. Maybe a
Nothing,
$sel:beenInSync:ChainState :: Bool
beenInSync = Bool
False,
$sel:peers:ChainState :: [Peer]
peers = []
}
let rd :: ChainReader
rd = ChainReader {$sel:config:ChainReader :: ChainConfig
config = ChainConfig
cfg, $sel:state:ChainReader :: TVar ChainState
state = TVar ChainState
st}
ch :: Chain
ch = Chain {$sel:reader:Chain :: ChainReader
reader = ChainReader
rd, $sel:mailbox:Chain :: Mailbox ChainMessage
mailbox = 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 a b. m a -> m b -> m b
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 a b. m a -> (a -> m b) -> m b
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
$(logDebugS) Text
"Chain" Text
"Awaiting event..."
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 (.config.pub)
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
b.height)
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
b.height)
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 a. [a] -> 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
p.label
Network
net <- (ChainReader -> Network) -> m Network
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.config.net)
UTCTime
now <- IO UTCTime -> m UTCTime
forall a. IO a -> m a
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 a b. m a -> (a -> m b) -> m b
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
p.label
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
pbest.header BlockHeader -> BlockHeader -> Bool
forall a. Eq a => a -> a -> Bool
/= BlockNode
best.header) (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 a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just Peer
_ -> () -> m ()
forall a. a -> m a
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 a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe Peer
Nothing -> () -> m ()
forall a. a -> m a
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
p.label
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 a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
False -> () -> m ()
forall a. a -> m a
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 a b. m a -> (a -> m b) -> m b
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 a. IO a -> m a
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 a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just
ChainSync
{ $sel:peer:ChainSync :: ChainSync -> Peer
peer = Peer
s,
$sel:best:ChainSync :: ChainSync -> Maybe BlockNode
best = 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 a. a -> m a
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
p.label
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 a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
False -> Maybe GetHeaders -> m (Maybe GetHeaders)
forall a. a -> m a
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
p.label
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 a. a -> m a
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
p.label
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
p.label
Peer -> m ()
forall (m :: * -> *). MonadChain m => Peer -> m ()
finishPeer Peer
p
m ()
forall (m :: * -> *). MonadChain m => m ()
syncNewPeer
chainMessage ChainMessage
ChainPing = do
$(logDebugS) Text
"Chain" Text
"Internal clock event"
NominalDiffTime
to <- (ChainReader -> NominalDiffTime) -> m NominalDiffTime
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.config.timeout)
UTCTime
now <- IO UTCTime -> m UTCTime
forall a. IO a -> m a
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 a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just ChainSync {$sel:peer:ChainSync :: ChainSync -> Peer
peer = Peer
p, $sel:timestamp:ChainSync :: ChainSync -> UTCTime
timestamp = 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
p.label
PeerException
PeerTimeout PeerException -> Peer -> m ()
forall (m :: * -> *). MonadIO m => PeerException -> Peer -> m ()
`killPeer` Peer
p
| Bool
otherwise -> () -> m ()
forall a. a -> m a
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 a b. m a -> m b -> m b
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 a. IO a -> m a
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
ch.mailbox
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 (.config.db)
Maybe ColumnFamily
mcf <- (ChainReader -> Maybe ColumnFamily) -> m (Maybe ColumnFamily)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.config.cf)
Network
net <- (ChainReader -> Network) -> m Network
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.config.net)
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 a b. m a -> (a -> m b) -> m b
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 a b. m a -> (a -> m b) -> m b
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 (.config.db)
Maybe ColumnFamily
mcf <- (ChainReader -> Maybe ColumnFamily) -> m (Maybe ColumnFamily)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.config.cf)
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 a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just ByteString
k
| HasCallStack => ByteString -> Word8
ByteString -> Word8
B.head ByteString
k Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x90 Bool -> Bool -> Bool
|| HasCallStack => ByteString -> Word8
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 a. a -> m a
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 (m :: * -> *) a. Monad m => m a -> ExceptT PeerException m a
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 a b.
ExceptT PeerException m a
-> (a -> ExceptT PeerException m b) -> ExceptT PeerException m b
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 a. a -> ExceptT PeerException m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
[BlockHeader]
_ -> do
Maybe BlockNode
bb <- m (Maybe BlockNode) -> ExceptT PeerException m (Maybe BlockNode)
forall (m :: * -> *) a. Monad m => m a -> ExceptT PeerException m a
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 (.state)
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 {syncing = (\ChainSync
x -> ChainSync
x {best = bb}) <$> s.syncing}
case [BlockHeader] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BlockHeader]
hs of
Int
2000 -> Bool -> ExceptT PeerException m Bool
forall a. a -> ExceptT PeerException m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
Int
_ -> Bool -> ExceptT PeerException m Bool
forall a. a -> ExceptT PeerException m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
Left String
_ -> PeerException -> ExceptT PeerException m Bool
forall a. PeerException -> ExceptT PeerException m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError PeerException
PeerSentBadHeaders
where
timestamp :: Word32
timestamp = NominalDiffTime -> Word32
forall b. Integral b => NominalDiffTime -> b
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. HasCallStack => [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 a b. (a -> b) -> m a -> m b
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 (m :: * -> *) a. Monad m => m a -> MaybeT m a
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 a. IO a -> MaybeT m a
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 (.state)
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 (m :: * -> *) a. Monad m => m a -> MaybeT m a
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 ()) -> Bool -> MaybeT STM ()
forall a b. (a -> b) -> a -> b
$ Maybe ChainSync -> Bool
forall a. Maybe a -> Bool
isNothing ChainState
s.syncing
Bool -> MaybeT STM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> MaybeT STM ()) -> Bool -> MaybeT STM ()
forall a b. (a -> b) -> a -> b
$ [Peer] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ChainState
s.peers
Bool -> MaybeT STM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> MaybeT STM ()) -> Bool -> MaybeT STM ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not ChainState
s.beenInSync
STM () -> MaybeT STM ()
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
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 {beenInSync = True}
() -> MaybeT STM ()
forall a. a -> MaybeT STM a
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
. (.header.timestamp)
nextPeer :: (MonadChain m) => m (Maybe Peer)
nextPeer :: forall (m :: * -> *). MonadChain m => m (Maybe Peer)
nextPeer = do
[Peer]
ps <- (.peers) (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 (.state))
[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 a. a -> m a
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 a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
True -> Maybe Peer -> m (Maybe Peer)
forall a. a -> m a
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 (.state)
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
{ syncing =
Just
ChainSync
{ peer = p,
timestamp = now,
best = Nothing
},
peers = delete p s.peers
}
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 a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return
GetHeaders
{ $sel:version:GetHeaders :: Word32
version = Word32
myVersion,
$sel:locator:GetHeaders :: BlockLocator
locator = BlockLocator
loc,
$sel:stop:GetHeaders :: BlockHash
stop = 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 a. IO a -> m a
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 (.state)
let f :: ChainSync -> ChainSync
f ChainSync {Maybe BlockNode
UTCTime
Peer
$sel:peer:ChainSync :: ChainSync -> Peer
$sel:timestamp:ChainSync :: ChainSync -> UTCTime
$sel:best:ChainSync :: ChainSync -> Maybe BlockNode
peer :: Peer
timestamp :: UTCTime
best :: Maybe BlockNode
..} = ChainSync {$sel:timestamp:ChainSync :: UTCTime
timestamp = UTCTime
now, Maybe BlockNode
Peer
$sel:peer:ChainSync :: Peer
$sel:best:ChainSync :: Maybe BlockNode
peer :: Peer
best :: Maybe BlockNode
..}
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 {syncing = f <$> s.syncing}
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 (.state)
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 {peers = nub (p : s.peers)}
getSyncingPeer :: (MonadChain m) => m (Maybe Peer)
getSyncingPeer :: forall (m :: * -> *). MonadChain m => m (Maybe Peer)
getSyncingPeer =
(ChainSync -> Peer) -> Maybe ChainSync -> Maybe Peer
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (.peer) (Maybe ChainSync -> Maybe Peer)
-> (ChainState -> Maybe ChainSync) -> ChainState -> Maybe Peer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.syncing)
(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 (.state))
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 a b. m a -> (a -> m b) -> m b
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
p.label
Bool -> m Bool
forall a. a -> m a
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
p.label
m ()
set_it
Bool -> m Bool
forall a. a -> m a
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 a. IO a -> m a
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 (.state)
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
{ syncing =
Just
ChainSync
{ peer = p,
timestamp = now,
best = 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 (.state) m (TVar ChainState) -> (TVar ChainState -> m Bool) -> m Bool
forall a b. m a -> (a -> m b) -> m b
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 a b. m a -> (a -> m b) -> m b
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
p.label
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
p.label
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 a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ChainState
s -> case ChainState
s.syncing of
Just ChainSync {$sel:peer:ChainSync :: ChainSync -> Peer
peer = 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 a. a -> STM a
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 a. a -> STM a
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 {syncing = 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 {peers = delete p x.peers}
chainSyncingPeer :: (MonadChain m) => m (Maybe ChainSync)
chainSyncingPeer :: forall (m :: * -> *). MonadChain m => m (Maybe ChainSync)
chainSyncingPeer =
(.syncing) (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 (.state))
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) (Chain
ch.reader.config)
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 Chain
ch.reader.config
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) Chain
ch.reader.config
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
b.height = [BlockNode] -> m [BlockNode]
forall a. a -> m a
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 BlockNode
b.header.prev Chain
ch
case Maybe BlockNode
m of
Maybe BlockNode
Nothing -> [BlockNode] -> m [BlockNode]
forall a. a -> m a
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) Chain
ch.reader.config
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
ch.mailbox
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
ch.mailbox
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 a b. m a -> (a -> m b) -> m b
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 a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe BlockNode
Nothing ->
Bool -> m Bool
forall a. a -> m a
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
bn.height BlockNode
bb Chain
ch
chainIsSynced :: (MonadIO m) => Chain -> m Bool
chainIsSynced :: forall (m :: * -> *). MonadIO m => Chain -> m Bool
chainIsSynced Chain
ch =
(.beenInSync) (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 (Chain
ch.reader.state)
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
ch.mailbox