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