{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
module Haskoin.Store.BlockStore
(
BlockStore,
BlockStoreConfig (..),
withBlockStore,
blockStorePeerConnect,
blockStorePeerConnectSTM,
blockStorePeerDisconnect,
blockStorePeerDisconnectSTM,
blockStoreHead,
blockStoreHeadSTM,
blockStoreBlock,
blockStoreBlockSTM,
blockStoreNotFound,
blockStoreNotFoundSTM,
blockStoreTx,
blockStoreTxSTM,
blockStoreTxHash,
blockStoreTxHashSTM,
blockStorePendingTxs,
blockStorePendingTxsSTM,
)
where
import Control.Monad
( forM,
forM_,
forever,
mzero,
unless,
void,
when,
)
import Control.Monad.Except
( ExceptT (..),
MonadError,
catchError,
runExceptT,
)
import Control.Monad.Logger
( MonadLoggerIO,
logDebugS,
logErrorS,
logInfoS,
logWarnS,
)
import Control.Monad.Reader
( MonadReader,
ReaderT (..),
ask,
asks,
)
import Control.Monad.Trans (lift)
import Control.Monad.Trans.Maybe (runMaybeT)
import qualified Data.ByteString as B
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.HashSet (HashSet)
import qualified Data.HashSet as HashSet
import Data.List (delete)
import Data.Maybe
( catMaybes,
fromJust,
isJust,
mapMaybe,
)
import Data.Serialize (encode)
import Data.String (fromString)
import Data.String.Conversions (cs)
import Data.Text (Text)
import Data.Time.Clock
( NominalDiffTime,
UTCTime,
diffUTCTime,
getCurrentTime,
)
import Data.Time.Clock.POSIX
( posixSecondsToUTCTime,
utcTimeToPOSIXSeconds,
)
import Data.Time.Format
( defaultTimeLocale,
formatTime,
iso8601DateFormat,
)
import Haskoin
( Block (..),
BlockHash (..),
BlockHeader (..),
BlockHeight,
BlockNode (..),
GetData (..),
InvType (..),
InvVector (..),
Message (..),
Network (..),
OutPoint (..),
Tx (..),
TxHash (..),
TxIn (..),
blockHashToHex,
headerHash,
txHash,
txHashToHex,
)
import Haskoin.Node
( Chain,
OnlinePeer (..),
Peer,
PeerException (..),
PeerManager,
chainBlockMain,
chainGetAncestor,
chainGetBest,
chainGetBlock,
chainGetParents,
getPeers,
killPeer,
peerText,
sendMessage,
setBusy,
setFree,
)
import Haskoin.Store.Common
import Haskoin.Store.Data
import Haskoin.Store.Database.Reader
import Haskoin.Store.Database.Writer
import Haskoin.Store.Logic
( ImportException (Orphan),
deleteUnconfirmedTx,
importBlock,
initBest,
newMempoolTx,
revertBlock,
)
import Haskoin.Store.Stats
import NQE
( Listen,
Mailbox,
Publisher,
inboxToMailbox,
newInbox,
publish,
query,
receive,
send,
sendSTM,
)
import qualified System.Metrics as Metrics
import qualified System.Metrics.Gauge as Metrics (Gauge)
import qualified System.Metrics.Gauge as Metrics.Gauge
import System.Random (randomRIO)
import UnliftIO
( Exception,
MonadIO,
MonadUnliftIO,
STM,
TVar,
async,
atomically,
liftIO,
link,
modifyTVar,
newTVarIO,
readTVar,
readTVarIO,
throwIO,
withAsync,
writeTVar,
)
import UnliftIO.Concurrent (threadDelay)
data BlockStoreMessage
= BlockNewBest !BlockNode
| BlockPeerConnect !Peer
| BlockPeerDisconnect !Peer
| BlockReceived !Peer !Block
| BlockNotFound !Peer ![BlockHash]
| TxRefReceived !Peer !Tx
| TxRefAvailable !Peer ![TxHash]
| BlockPing !(Listen ())
data BlockException
= BlockNotInChain !BlockHash
| Uninitialized
| CorruptDatabase
| AncestorNotInChain !BlockHeight !BlockHash
| MempoolImportFailed
deriving (Int -> BlockException -> ShowS
[BlockException] -> ShowS
BlockException -> String
(Int -> BlockException -> ShowS)
-> (BlockException -> String)
-> ([BlockException] -> ShowS)
-> Show BlockException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BlockException] -> ShowS
$cshowList :: [BlockException] -> ShowS
show :: BlockException -> String
$cshow :: BlockException -> String
showsPrec :: Int -> BlockException -> ShowS
$cshowsPrec :: Int -> BlockException -> ShowS
Show, BlockException -> BlockException -> Bool
(BlockException -> BlockException -> Bool)
-> (BlockException -> BlockException -> Bool) -> Eq BlockException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BlockException -> BlockException -> Bool
$c/= :: BlockException -> BlockException -> Bool
== :: BlockException -> BlockException -> Bool
$c== :: BlockException -> BlockException -> Bool
Eq, Eq BlockException
Eq BlockException
-> (BlockException -> BlockException -> Ordering)
-> (BlockException -> BlockException -> Bool)
-> (BlockException -> BlockException -> Bool)
-> (BlockException -> BlockException -> Bool)
-> (BlockException -> BlockException -> Bool)
-> (BlockException -> BlockException -> BlockException)
-> (BlockException -> BlockException -> BlockException)
-> Ord BlockException
BlockException -> BlockException -> Bool
BlockException -> BlockException -> Ordering
BlockException -> BlockException -> BlockException
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 :: BlockException -> BlockException -> BlockException
$cmin :: BlockException -> BlockException -> BlockException
max :: BlockException -> BlockException -> BlockException
$cmax :: BlockException -> BlockException -> BlockException
>= :: BlockException -> BlockException -> Bool
$c>= :: BlockException -> BlockException -> Bool
> :: BlockException -> BlockException -> Bool
$c> :: BlockException -> BlockException -> Bool
<= :: BlockException -> BlockException -> Bool
$c<= :: BlockException -> BlockException -> Bool
< :: BlockException -> BlockException -> Bool
$c< :: BlockException -> BlockException -> Bool
compare :: BlockException -> BlockException -> Ordering
$ccompare :: BlockException -> BlockException -> Ordering
$cp1Ord :: Eq BlockException
Ord, Show BlockException
Typeable BlockException
Typeable BlockException
-> Show BlockException
-> (BlockException -> SomeException)
-> (SomeException -> Maybe BlockException)
-> (BlockException -> String)
-> Exception BlockException
SomeException -> Maybe BlockException
BlockException -> String
BlockException -> SomeException
forall e.
Typeable e
-> Show e
-> (e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> Exception e
displayException :: BlockException -> String
$cdisplayException :: BlockException -> String
fromException :: SomeException -> Maybe BlockException
$cfromException :: SomeException -> Maybe BlockException
toException :: BlockException -> SomeException
$ctoException :: BlockException -> SomeException
$cp2Exception :: Show BlockException
$cp1Exception :: Typeable BlockException
Exception)
data Syncing = Syncing
{ Syncing -> Peer
syncingPeer :: !Peer,
Syncing -> UTCTime
syncingTime :: !UTCTime,
Syncing -> [BlockHash]
syncingBlocks :: ![BlockHash]
}
data PendingTx = PendingTx
{ PendingTx -> UTCTime
pendingTxTime :: !UTCTime,
PendingTx -> Tx
pendingTx :: !Tx,
PendingTx -> HashSet TxHash
pendingDeps :: !(HashSet TxHash)
}
deriving (Int -> PendingTx -> ShowS
[PendingTx] -> ShowS
PendingTx -> String
(Int -> PendingTx -> ShowS)
-> (PendingTx -> String)
-> ([PendingTx] -> ShowS)
-> Show PendingTx
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PendingTx] -> ShowS
$cshowList :: [PendingTx] -> ShowS
show :: PendingTx -> String
$cshow :: PendingTx -> String
showsPrec :: Int -> PendingTx -> ShowS
$cshowsPrec :: Int -> PendingTx -> ShowS
Show, PendingTx -> PendingTx -> Bool
(PendingTx -> PendingTx -> Bool)
-> (PendingTx -> PendingTx -> Bool) -> Eq PendingTx
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PendingTx -> PendingTx -> Bool
$c/= :: PendingTx -> PendingTx -> Bool
== :: PendingTx -> PendingTx -> Bool
$c== :: PendingTx -> PendingTx -> Bool
Eq, Eq PendingTx
Eq PendingTx
-> (PendingTx -> PendingTx -> Ordering)
-> (PendingTx -> PendingTx -> Bool)
-> (PendingTx -> PendingTx -> Bool)
-> (PendingTx -> PendingTx -> Bool)
-> (PendingTx -> PendingTx -> Bool)
-> (PendingTx -> PendingTx -> PendingTx)
-> (PendingTx -> PendingTx -> PendingTx)
-> Ord PendingTx
PendingTx -> PendingTx -> Bool
PendingTx -> PendingTx -> Ordering
PendingTx -> PendingTx -> PendingTx
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 :: PendingTx -> PendingTx -> PendingTx
$cmin :: PendingTx -> PendingTx -> PendingTx
max :: PendingTx -> PendingTx -> PendingTx
$cmax :: PendingTx -> PendingTx -> PendingTx
>= :: PendingTx -> PendingTx -> Bool
$c>= :: PendingTx -> PendingTx -> Bool
> :: PendingTx -> PendingTx -> Bool
$c> :: PendingTx -> PendingTx -> Bool
<= :: PendingTx -> PendingTx -> Bool
$c<= :: PendingTx -> PendingTx -> Bool
< :: PendingTx -> PendingTx -> Bool
$c< :: PendingTx -> PendingTx -> Bool
compare :: PendingTx -> PendingTx -> Ordering
$ccompare :: PendingTx -> PendingTx -> Ordering
$cp1Ord :: Eq PendingTx
Ord)
data BlockStore = BlockStore
{ BlockStore -> Mailbox BlockStoreMessage
myMailbox :: !(Mailbox BlockStoreMessage),
BlockStore -> BlockStoreConfig
myConfig :: !BlockStoreConfig,
BlockStore -> TVar (Maybe Syncing)
myPeer :: !(TVar (Maybe Syncing)),
BlockStore -> TVar (HashMap TxHash PendingTx)
myTxs :: !(TVar (HashMap TxHash PendingTx)),
BlockStore -> TVar (HashSet TxHash)
requested :: !(TVar (HashSet TxHash)),
BlockStore -> Maybe StoreMetrics
myMetrics :: !(Maybe StoreMetrics)
}
data StoreMetrics = StoreMetrics
{ StoreMetrics -> Gauge
storeHeight :: !Metrics.Gauge,
:: !Metrics.Gauge,
StoreMetrics -> Gauge
storePendingTxs :: !Metrics.Gauge,
StoreMetrics -> Gauge
storePeersConnected :: !Metrics.Gauge,
StoreMetrics -> Gauge
storeMempoolSize :: !Metrics.Gauge
}
newStoreMetrics :: MonadIO m => Metrics.Store -> m StoreMetrics
newStoreMetrics :: Store -> m StoreMetrics
newStoreMetrics Store
s = IO StoreMetrics -> m StoreMetrics
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO StoreMetrics -> m StoreMetrics)
-> IO StoreMetrics -> m StoreMetrics
forall a b. (a -> b) -> a -> b
$ do
Gauge
storeHeight <- Text -> IO Gauge
g Text
"blockchain.height"
Gauge
headersHeight <- Text -> IO Gauge
g Text
"blockchain.headers"
Gauge
storePendingTxs <- Text -> IO Gauge
g Text
"mempool.pending_txs"
Gauge
storePeersConnected <- Text -> IO Gauge
g Text
"network.peers_connected"
Gauge
storeMempoolSize <- Text -> IO Gauge
g Text
"mempool.size"
StoreMetrics -> IO StoreMetrics
forall (m :: * -> *) a. Monad m => a -> m a
return StoreMetrics :: Gauge -> Gauge -> Gauge -> Gauge -> Gauge -> StoreMetrics
StoreMetrics {Gauge
storeMempoolSize :: Gauge
storePeersConnected :: Gauge
storePendingTxs :: Gauge
headersHeight :: Gauge
storeHeight :: Gauge
storeMempoolSize :: Gauge
storePeersConnected :: Gauge
storePendingTxs :: Gauge
headersHeight :: Gauge
storeHeight :: Gauge
..}
where
g :: Text -> IO Gauge
g Text
x = Text -> Store -> IO Gauge
Metrics.createGauge (Text
"store." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x) Store
s
setStoreHeight :: MonadIO m => BlockT m ()
setStoreHeight :: BlockT m ()
setStoreHeight =
(BlockStore -> Maybe StoreMetrics)
-> ReaderT BlockStore m (Maybe StoreMetrics)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> Maybe StoreMetrics
myMetrics ReaderT BlockStore m (Maybe StoreMetrics)
-> (Maybe StoreMetrics -> BlockT m ()) -> BlockT m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe StoreMetrics
Nothing -> () -> BlockT m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just StoreMetrics
m ->
ReaderT BlockStore m (Maybe BlockHash)
forall (m :: * -> *). StoreReadBase m => m (Maybe BlockHash)
getBestBlock ReaderT BlockStore m (Maybe BlockHash)
-> (Maybe BlockHash -> BlockT m ()) -> BlockT m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe BlockHash
Nothing -> StoreMetrics -> Integer -> BlockT m ()
forall (m :: * -> *) a.
(MonadIO m, Integral a) =>
StoreMetrics -> a -> m ()
setit StoreMetrics
m Integer
0
Just BlockHash
bb ->
BlockHash -> ReaderT BlockStore m (Maybe BlockData)
forall (m :: * -> *).
StoreReadBase m =>
BlockHash -> m (Maybe BlockData)
getBlock BlockHash
bb ReaderT BlockStore m (Maybe BlockData)
-> (Maybe BlockData -> BlockT m ()) -> BlockT m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe BlockData
Nothing -> StoreMetrics -> Integer -> BlockT m ()
forall (m :: * -> *) a.
(MonadIO m, Integral a) =>
StoreMetrics -> a -> m ()
setit StoreMetrics
m Integer
0
Just BlockData
b -> StoreMetrics -> BlockHeight -> BlockT m ()
forall (m :: * -> *) a.
(MonadIO m, Integral a) =>
StoreMetrics -> a -> m ()
setit StoreMetrics
m (BlockData -> BlockHeight
blockDataHeight BlockData
b)
where
setit :: StoreMetrics -> a -> m ()
setit StoreMetrics
m a
i = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ StoreMetrics -> Gauge
storeHeight StoreMetrics
m Gauge -> Int64 -> IO ()
`Metrics.Gauge.set` a -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
i
setHeadersHeight :: MonadIO m => BlockT m ()
=
(BlockStore -> Maybe StoreMetrics)
-> ReaderT BlockStore m (Maybe StoreMetrics)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> Maybe StoreMetrics
myMetrics ReaderT BlockStore m (Maybe StoreMetrics)
-> (Maybe StoreMetrics -> BlockT m ()) -> BlockT m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe StoreMetrics
Nothing -> () -> BlockT m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just StoreMetrics
m -> do
BlockHeight
h <- (BlockNode -> BlockHeight)
-> ReaderT BlockStore m BlockNode
-> ReaderT BlockStore m BlockHeight
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BlockNode -> BlockHeight
nodeHeight (ReaderT BlockStore m BlockNode
-> ReaderT BlockStore m BlockHeight)
-> ReaderT BlockStore m BlockNode
-> ReaderT BlockStore m BlockHeight
forall a b. (a -> b) -> a -> b
$ Chain -> ReaderT BlockStore m BlockNode
forall (m :: * -> *). MonadIO m => Chain -> m BlockNode
chainGetBest (Chain -> ReaderT BlockStore m BlockNode)
-> ReaderT BlockStore m Chain -> ReaderT BlockStore m BlockNode
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (BlockStore -> Chain) -> ReaderT BlockStore m Chain
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (BlockStoreConfig -> Chain
blockConfChain (BlockStoreConfig -> Chain)
-> (BlockStore -> BlockStoreConfig) -> BlockStore -> Chain
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockStore -> BlockStoreConfig
myConfig)
IO () -> BlockT m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> BlockT m ()) -> IO () -> BlockT m ()
forall a b. (a -> b) -> a -> b
$ StoreMetrics -> Gauge
headersHeight StoreMetrics
m Gauge -> Int64 -> IO ()
`Metrics.Gauge.set` BlockHeight -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral BlockHeight
h
setPendingTxs :: MonadIO m => BlockT m ()
setPendingTxs :: BlockT m ()
setPendingTxs =
(BlockStore -> Maybe StoreMetrics)
-> ReaderT BlockStore m (Maybe StoreMetrics)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> Maybe StoreMetrics
myMetrics ReaderT BlockStore m (Maybe StoreMetrics)
-> (Maybe StoreMetrics -> BlockT m ()) -> BlockT m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe StoreMetrics
Nothing -> () -> BlockT m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just StoreMetrics
m -> do
Int
s <- (BlockStore -> TVar (HashMap TxHash PendingTx))
-> ReaderT BlockStore m (TVar (HashMap TxHash PendingTx))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> TVar (HashMap TxHash PendingTx)
myTxs ReaderT BlockStore m (TVar (HashMap TxHash PendingTx))
-> (TVar (HashMap TxHash PendingTx) -> ReaderT BlockStore m Int)
-> ReaderT BlockStore m Int
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \TVar (HashMap TxHash PendingTx)
t -> STM Int -> ReaderT BlockStore m Int
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (HashMap TxHash PendingTx -> Int
forall k v. HashMap k v -> Int
HashMap.size (HashMap TxHash PendingTx -> Int)
-> STM (HashMap TxHash PendingTx) -> STM Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (HashMap TxHash PendingTx) -> STM (HashMap TxHash PendingTx)
forall a. TVar a -> STM a
readTVar TVar (HashMap TxHash PendingTx)
t)
IO () -> BlockT m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> BlockT m ()) -> IO () -> BlockT m ()
forall a b. (a -> b) -> a -> b
$ StoreMetrics -> Gauge
storePendingTxs StoreMetrics
m Gauge -> Int64 -> IO ()
`Metrics.Gauge.set` Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
s
setPeersConnected :: MonadIO m => BlockT m ()
setPeersConnected :: BlockT m ()
setPeersConnected =
(BlockStore -> Maybe StoreMetrics)
-> ReaderT BlockStore m (Maybe StoreMetrics)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> Maybe StoreMetrics
myMetrics ReaderT BlockStore m (Maybe StoreMetrics)
-> (Maybe StoreMetrics -> BlockT m ()) -> BlockT m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe StoreMetrics
Nothing -> () -> BlockT m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just StoreMetrics
m -> do
Int
ps <- ([OnlinePeer] -> Int)
-> ReaderT BlockStore m [OnlinePeer] -> ReaderT BlockStore m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [OnlinePeer] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (ReaderT BlockStore m [OnlinePeer] -> ReaderT BlockStore m Int)
-> ReaderT BlockStore m [OnlinePeer] -> ReaderT BlockStore m Int
forall a b. (a -> b) -> a -> b
$ PeerManager -> ReaderT BlockStore m [OnlinePeer]
forall (m :: * -> *). MonadIO m => PeerManager -> m [OnlinePeer]
getPeers (PeerManager -> ReaderT BlockStore m [OnlinePeer])
-> ReaderT BlockStore m PeerManager
-> ReaderT BlockStore m [OnlinePeer]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (BlockStore -> PeerManager) -> ReaderT BlockStore m PeerManager
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (BlockStoreConfig -> PeerManager
blockConfManager (BlockStoreConfig -> PeerManager)
-> (BlockStore -> BlockStoreConfig) -> BlockStore -> PeerManager
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockStore -> BlockStoreConfig
myConfig)
IO () -> BlockT m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> BlockT m ()) -> IO () -> BlockT m ()
forall a b. (a -> b) -> a -> b
$ StoreMetrics -> Gauge
storePeersConnected StoreMetrics
m Gauge -> Int64 -> IO ()
`Metrics.Gauge.set` Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ps
setMempoolSize :: MonadIO m => BlockT m ()
setMempoolSize :: BlockT m ()
setMempoolSize =
(BlockStore -> Maybe StoreMetrics)
-> ReaderT BlockStore m (Maybe StoreMetrics)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> Maybe StoreMetrics
myMetrics ReaderT BlockStore m (Maybe StoreMetrics)
-> (Maybe StoreMetrics -> BlockT m ()) -> BlockT m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe StoreMetrics
Nothing -> () -> BlockT m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just StoreMetrics
m -> do
Int
s <- [(UnixTime, TxHash)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([(UnixTime, TxHash)] -> Int)
-> ReaderT BlockStore m [(UnixTime, TxHash)]
-> ReaderT BlockStore m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT BlockStore m [(UnixTime, TxHash)]
forall (m :: * -> *). StoreReadBase m => m [(UnixTime, TxHash)]
getMempool
IO () -> BlockT m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> BlockT m ()) -> IO () -> BlockT m ()
forall a b. (a -> b) -> a -> b
$ StoreMetrics -> Gauge
storeMempoolSize StoreMetrics
m Gauge -> Int64 -> IO ()
`Metrics.Gauge.set` Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
s
data BlockStoreConfig = BlockStoreConfig
{
BlockStoreConfig -> PeerManager
blockConfManager :: !PeerManager,
BlockStoreConfig -> Chain
blockConfChain :: !Chain,
BlockStoreConfig -> Publisher StoreEvent
blockConfListener :: !(Publisher StoreEvent),
BlockStoreConfig -> DatabaseReader
blockConfDB :: !DatabaseReader,
BlockStoreConfig -> Network
blockConfNet :: !Network,
BlockStoreConfig -> Bool
blockConfNoMempool :: !Bool,
BlockStoreConfig -> Bool
blockConfWipeMempool :: !Bool,
BlockStoreConfig -> Bool
blockConfSyncMempool :: !Bool,
BlockStoreConfig -> NominalDiffTime
blockConfPeerTimeout :: !NominalDiffTime,
BlockStoreConfig -> Maybe Store
blockConfStats :: !(Maybe Metrics.Store)
}
type BlockT m = ReaderT BlockStore m
runImport ::
MonadLoggerIO m =>
WriterT (ExceptT ImportException m) a ->
BlockT m (Either ImportException a)
runImport :: WriterT (ExceptT ImportException m) a
-> BlockT m (Either ImportException a)
runImport WriterT (ExceptT ImportException m) a
f =
(BlockStore -> m (Either ImportException a))
-> BlockT m (Either ImportException a)
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((BlockStore -> m (Either ImportException a))
-> BlockT m (Either ImportException a))
-> (BlockStore -> m (Either ImportException a))
-> BlockT m (Either ImportException a)
forall a b. (a -> b) -> a -> b
$ \BlockStore
r -> ExceptT ImportException m a -> m (Either ImportException a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT ImportException m a -> m (Either ImportException a))
-> ExceptT ImportException m a -> m (Either ImportException a)
forall a b. (a -> b) -> a -> b
$ DatabaseReader
-> WriterT (ExceptT ImportException m) a
-> ExceptT ImportException m a
forall (m :: * -> *) a.
MonadIO m =>
DatabaseReader -> WriterT m a -> m a
runWriter (BlockStoreConfig -> DatabaseReader
blockConfDB (BlockStore -> BlockStoreConfig
myConfig BlockStore
r)) WriterT (ExceptT ImportException m) a
f
runRocksDB :: ReaderT DatabaseReader m a -> BlockT m a
runRocksDB :: ReaderT DatabaseReader m a -> BlockT m a
runRocksDB ReaderT DatabaseReader m a
f =
(BlockStore -> m a) -> BlockT m a
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((BlockStore -> m a) -> BlockT m a)
-> (BlockStore -> m a) -> BlockT m a
forall a b. (a -> b) -> a -> b
$ ReaderT DatabaseReader m a -> DatabaseReader -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT DatabaseReader m a
f (DatabaseReader -> m a)
-> (BlockStore -> DatabaseReader) -> BlockStore -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockStoreConfig -> DatabaseReader
blockConfDB (BlockStoreConfig -> DatabaseReader)
-> (BlockStore -> BlockStoreConfig) -> BlockStore -> DatabaseReader
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockStore -> BlockStoreConfig
myConfig
instance MonadIO m => StoreReadBase (BlockT m) where
getNetwork :: BlockT m Network
getNetwork =
ReaderT DatabaseReader m Network -> BlockT m Network
forall (m :: * -> *) a. ReaderT DatabaseReader m a -> BlockT m a
runRocksDB ReaderT DatabaseReader m Network
forall (m :: * -> *). StoreReadBase m => m Network
getNetwork
getBestBlock :: BlockT m (Maybe BlockHash)
getBestBlock =
ReaderT DatabaseReader m (Maybe BlockHash)
-> BlockT m (Maybe BlockHash)
forall (m :: * -> *) a. ReaderT DatabaseReader m a -> BlockT m a
runRocksDB ReaderT DatabaseReader m (Maybe BlockHash)
forall (m :: * -> *). StoreReadBase m => m (Maybe BlockHash)
getBestBlock
getBlocksAtHeight :: BlockHeight -> BlockT m [BlockHash]
getBlocksAtHeight =
ReaderT DatabaseReader m [BlockHash] -> BlockT m [BlockHash]
forall (m :: * -> *) a. ReaderT DatabaseReader m a -> BlockT m a
runRocksDB (ReaderT DatabaseReader m [BlockHash] -> BlockT m [BlockHash])
-> (BlockHeight -> ReaderT DatabaseReader m [BlockHash])
-> BlockHeight
-> BlockT m [BlockHash]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockHeight -> ReaderT DatabaseReader m [BlockHash]
forall (m :: * -> *).
StoreReadBase m =>
BlockHeight -> m [BlockHash]
getBlocksAtHeight
getBlock :: BlockHash -> BlockT m (Maybe BlockData)
getBlock =
ReaderT DatabaseReader m (Maybe BlockData)
-> BlockT m (Maybe BlockData)
forall (m :: * -> *) a. ReaderT DatabaseReader m a -> BlockT m a
runRocksDB (ReaderT DatabaseReader m (Maybe BlockData)
-> BlockT m (Maybe BlockData))
-> (BlockHash -> ReaderT DatabaseReader m (Maybe BlockData))
-> BlockHash
-> BlockT m (Maybe BlockData)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockHash -> ReaderT DatabaseReader m (Maybe BlockData)
forall (m :: * -> *).
StoreReadBase m =>
BlockHash -> m (Maybe BlockData)
getBlock
getTxData :: TxHash -> BlockT m (Maybe TxData)
getTxData =
ReaderT DatabaseReader m (Maybe TxData) -> BlockT m (Maybe TxData)
forall (m :: * -> *) a. ReaderT DatabaseReader m a -> BlockT m a
runRocksDB (ReaderT DatabaseReader m (Maybe TxData)
-> BlockT m (Maybe TxData))
-> (TxHash -> ReaderT DatabaseReader m (Maybe TxData))
-> TxHash
-> BlockT m (Maybe TxData)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxHash -> ReaderT DatabaseReader m (Maybe TxData)
forall (m :: * -> *). StoreReadBase m => TxHash -> m (Maybe TxData)
getTxData
getSpender :: OutPoint -> BlockT m (Maybe Spender)
getSpender =
ReaderT DatabaseReader m (Maybe Spender)
-> BlockT m (Maybe Spender)
forall (m :: * -> *) a. ReaderT DatabaseReader m a -> BlockT m a
runRocksDB (ReaderT DatabaseReader m (Maybe Spender)
-> BlockT m (Maybe Spender))
-> (OutPoint -> ReaderT DatabaseReader m (Maybe Spender))
-> OutPoint
-> BlockT m (Maybe Spender)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OutPoint -> ReaderT DatabaseReader m (Maybe Spender)
forall (m :: * -> *).
StoreReadBase m =>
OutPoint -> m (Maybe Spender)
getSpender
getUnspent :: OutPoint -> BlockT m (Maybe Unspent)
getUnspent =
ReaderT DatabaseReader m (Maybe Unspent)
-> BlockT m (Maybe Unspent)
forall (m :: * -> *) a. ReaderT DatabaseReader m a -> BlockT m a
runRocksDB (ReaderT DatabaseReader m (Maybe Unspent)
-> BlockT m (Maybe Unspent))
-> (OutPoint -> ReaderT DatabaseReader m (Maybe Unspent))
-> OutPoint
-> BlockT m (Maybe Unspent)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OutPoint -> ReaderT DatabaseReader m (Maybe Unspent)
forall (m :: * -> *).
StoreReadBase m =>
OutPoint -> m (Maybe Unspent)
getUnspent
getBalance :: Address -> BlockT m (Maybe Balance)
getBalance =
ReaderT DatabaseReader m (Maybe Balance)
-> BlockT m (Maybe Balance)
forall (m :: * -> *) a. ReaderT DatabaseReader m a -> BlockT m a
runRocksDB (ReaderT DatabaseReader m (Maybe Balance)
-> BlockT m (Maybe Balance))
-> (Address -> ReaderT DatabaseReader m (Maybe Balance))
-> Address
-> BlockT m (Maybe Balance)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Address -> ReaderT DatabaseReader m (Maybe Balance)
forall (m :: * -> *).
StoreReadBase m =>
Address -> m (Maybe Balance)
getBalance
getMempool :: BlockT m [(UnixTime, TxHash)]
getMempool =
ReaderT DatabaseReader m [(UnixTime, TxHash)]
-> BlockT m [(UnixTime, TxHash)]
forall (m :: * -> *) a. ReaderT DatabaseReader m a -> BlockT m a
runRocksDB ReaderT DatabaseReader m [(UnixTime, TxHash)]
forall (m :: * -> *). StoreReadBase m => m [(UnixTime, TxHash)]
getMempool
instance MonadUnliftIO m => StoreReadExtra (BlockT m) where
getMaxGap :: BlockT m BlockHeight
getMaxGap =
ReaderT DatabaseReader m BlockHeight -> BlockT m BlockHeight
forall (m :: * -> *) a. ReaderT DatabaseReader m a -> BlockT m a
runRocksDB ReaderT DatabaseReader m BlockHeight
forall (m :: * -> *). StoreReadExtra m => m BlockHeight
getMaxGap
getInitialGap :: BlockT m BlockHeight
getInitialGap =
ReaderT DatabaseReader m BlockHeight -> BlockT m BlockHeight
forall (m :: * -> *) a. ReaderT DatabaseReader m a -> BlockT m a
runRocksDB ReaderT DatabaseReader m BlockHeight
forall (m :: * -> *). StoreReadExtra m => m BlockHeight
getInitialGap
getAddressesTxs :: [Address] -> Limits -> BlockT m [TxRef]
getAddressesTxs [Address]
as =
ReaderT DatabaseReader m [TxRef] -> BlockT m [TxRef]
forall (m :: * -> *) a. ReaderT DatabaseReader m a -> BlockT m a
runRocksDB (ReaderT DatabaseReader m [TxRef] -> BlockT m [TxRef])
-> (Limits -> ReaderT DatabaseReader m [TxRef])
-> Limits
-> BlockT m [TxRef]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Address] -> Limits -> ReaderT DatabaseReader m [TxRef]
forall (m :: * -> *).
StoreReadExtra m =>
[Address] -> Limits -> m [TxRef]
getAddressesTxs [Address]
as
getAddressesUnspents :: [Address] -> Limits -> BlockT m [Unspent]
getAddressesUnspents [Address]
as =
ReaderT DatabaseReader m [Unspent] -> BlockT m [Unspent]
forall (m :: * -> *) a. ReaderT DatabaseReader m a -> BlockT m a
runRocksDB (ReaderT DatabaseReader m [Unspent] -> BlockT m [Unspent])
-> (Limits -> ReaderT DatabaseReader m [Unspent])
-> Limits
-> BlockT m [Unspent]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Address] -> Limits -> ReaderT DatabaseReader m [Unspent]
forall (m :: * -> *).
StoreReadExtra m =>
[Address] -> Limits -> m [Unspent]
getAddressesUnspents [Address]
as
getAddressUnspents :: Address -> Limits -> BlockT m [Unspent]
getAddressUnspents Address
a =
ReaderT DatabaseReader m [Unspent] -> BlockT m [Unspent]
forall (m :: * -> *) a. ReaderT DatabaseReader m a -> BlockT m a
runRocksDB (ReaderT DatabaseReader m [Unspent] -> BlockT m [Unspent])
-> (Limits -> ReaderT DatabaseReader m [Unspent])
-> Limits
-> BlockT m [Unspent]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Address -> Limits -> ReaderT DatabaseReader m [Unspent]
forall (m :: * -> *).
StoreReadExtra m =>
Address -> Limits -> m [Unspent]
getAddressUnspents Address
a
getAddressTxs :: Address -> Limits -> BlockT m [TxRef]
getAddressTxs Address
a =
ReaderT DatabaseReader m [TxRef] -> BlockT m [TxRef]
forall (m :: * -> *) a. ReaderT DatabaseReader m a -> BlockT m a
runRocksDB (ReaderT DatabaseReader m [TxRef] -> BlockT m [TxRef])
-> (Limits -> ReaderT DatabaseReader m [TxRef])
-> Limits
-> BlockT m [TxRef]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Address -> Limits -> ReaderT DatabaseReader m [TxRef]
forall (m :: * -> *).
StoreReadExtra m =>
Address -> Limits -> m [TxRef]
getAddressTxs Address
a
getNumTxData :: UnixTime -> BlockT m [TxData]
getNumTxData =
ReaderT DatabaseReader m [TxData] -> BlockT m [TxData]
forall (m :: * -> *) a. ReaderT DatabaseReader m a -> BlockT m a
runRocksDB (ReaderT DatabaseReader m [TxData] -> BlockT m [TxData])
-> (UnixTime -> ReaderT DatabaseReader m [TxData])
-> UnixTime
-> BlockT m [TxData]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnixTime -> ReaderT DatabaseReader m [TxData]
forall (m :: * -> *). StoreReadExtra m => UnixTime -> m [TxData]
getNumTxData
getBalances :: [Address] -> BlockT m [Balance]
getBalances =
ReaderT DatabaseReader m [Balance] -> BlockT m [Balance]
forall (m :: * -> *) a. ReaderT DatabaseReader m a -> BlockT m a
runRocksDB (ReaderT DatabaseReader m [Balance] -> BlockT m [Balance])
-> ([Address] -> ReaderT DatabaseReader m [Balance])
-> [Address]
-> BlockT m [Balance]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Address] -> ReaderT DatabaseReader m [Balance]
forall (m :: * -> *). StoreReadExtra m => [Address] -> m [Balance]
getBalances
xPubBals :: XPubSpec -> BlockT m [XPubBal]
xPubBals =
ReaderT DatabaseReader m [XPubBal] -> BlockT m [XPubBal]
forall (m :: * -> *) a. ReaderT DatabaseReader m a -> BlockT m a
runRocksDB (ReaderT DatabaseReader m [XPubBal] -> BlockT m [XPubBal])
-> (XPubSpec -> ReaderT DatabaseReader m [XPubBal])
-> XPubSpec
-> BlockT m [XPubBal]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XPubSpec -> ReaderT DatabaseReader m [XPubBal]
forall (m :: * -> *). StoreReadExtra m => XPubSpec -> m [XPubBal]
xPubBals
xPubUnspents :: XPubSpec -> [XPubBal] -> Limits -> BlockT m [XPubUnspent]
xPubUnspents XPubSpec
x [XPubBal]
l =
ReaderT DatabaseReader m [XPubUnspent] -> BlockT m [XPubUnspent]
forall (m :: * -> *) a. ReaderT DatabaseReader m a -> BlockT m a
runRocksDB (ReaderT DatabaseReader m [XPubUnspent] -> BlockT m [XPubUnspent])
-> (Limits -> ReaderT DatabaseReader m [XPubUnspent])
-> Limits
-> BlockT m [XPubUnspent]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XPubSpec
-> [XPubBal] -> Limits -> ReaderT DatabaseReader m [XPubUnspent]
forall (m :: * -> *).
StoreReadExtra m =>
XPubSpec -> [XPubBal] -> Limits -> m [XPubUnspent]
xPubUnspents XPubSpec
x [XPubBal]
l
xPubTxs :: XPubSpec -> [XPubBal] -> Limits -> BlockT m [TxRef]
xPubTxs XPubSpec
x [XPubBal]
l =
ReaderT DatabaseReader m [TxRef] -> BlockT m [TxRef]
forall (m :: * -> *) a. ReaderT DatabaseReader m a -> BlockT m a
runRocksDB (ReaderT DatabaseReader m [TxRef] -> BlockT m [TxRef])
-> (Limits -> ReaderT DatabaseReader m [TxRef])
-> Limits
-> BlockT m [TxRef]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XPubSpec -> [XPubBal] -> Limits -> ReaderT DatabaseReader m [TxRef]
forall (m :: * -> *).
StoreReadExtra m =>
XPubSpec -> [XPubBal] -> Limits -> m [TxRef]
xPubTxs XPubSpec
x [XPubBal]
l
xPubTxCount :: XPubSpec -> [XPubBal] -> BlockT m BlockHeight
xPubTxCount XPubSpec
x =
ReaderT DatabaseReader m BlockHeight -> BlockT m BlockHeight
forall (m :: * -> *) a. ReaderT DatabaseReader m a -> BlockT m a
runRocksDB (ReaderT DatabaseReader m BlockHeight -> BlockT m BlockHeight)
-> ([XPubBal] -> ReaderT DatabaseReader m BlockHeight)
-> [XPubBal]
-> BlockT m BlockHeight
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XPubSpec -> [XPubBal] -> ReaderT DatabaseReader m BlockHeight
forall (m :: * -> *).
StoreReadExtra m =>
XPubSpec -> [XPubBal] -> m BlockHeight
xPubTxCount XPubSpec
x
withBlockStore ::
(MonadUnliftIO m, MonadLoggerIO m) =>
BlockStoreConfig ->
(BlockStore -> m a) ->
m a
withBlockStore :: BlockStoreConfig -> (BlockStore -> m a) -> m a
withBlockStore BlockStoreConfig
cfg BlockStore -> m a
action = do
TVar (Maybe Syncing)
pb <- Maybe Syncing -> m (TVar (Maybe Syncing))
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Maybe Syncing
forall a. Maybe a
Nothing
TVar (HashMap TxHash PendingTx)
ts <- HashMap TxHash PendingTx -> m (TVar (HashMap TxHash PendingTx))
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO HashMap TxHash PendingTx
forall k v. HashMap k v
HashMap.empty
TVar (HashSet TxHash)
rq <- HashSet TxHash -> m (TVar (HashSet TxHash))
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO HashSet TxHash
forall a. HashSet a
HashSet.empty
Inbox BlockStoreMessage
inbox <- m (Inbox BlockStoreMessage)
forall (m :: * -> *) msg. MonadIO m => m (Inbox msg)
newInbox
Maybe StoreMetrics
metrics <- (Store -> m StoreMetrics) -> Maybe Store -> m (Maybe StoreMetrics)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Store -> m StoreMetrics
forall (m :: * -> *). MonadIO m => Store -> m StoreMetrics
newStoreMetrics (BlockStoreConfig -> Maybe Store
blockConfStats BlockStoreConfig
cfg)
let r :: BlockStore
r =
BlockStore :: Mailbox BlockStoreMessage
-> BlockStoreConfig
-> TVar (Maybe Syncing)
-> TVar (HashMap TxHash PendingTx)
-> TVar (HashSet TxHash)
-> Maybe StoreMetrics
-> BlockStore
BlockStore
{ myMailbox :: Mailbox BlockStoreMessage
myMailbox = Inbox BlockStoreMessage -> Mailbox BlockStoreMessage
forall msg. Inbox msg -> Mailbox msg
inboxToMailbox Inbox BlockStoreMessage
inbox,
myConfig :: BlockStoreConfig
myConfig = BlockStoreConfig
cfg,
myPeer :: TVar (Maybe Syncing)
myPeer = TVar (Maybe Syncing)
pb,
myTxs :: TVar (HashMap TxHash PendingTx)
myTxs = TVar (HashMap TxHash PendingTx)
ts,
requested :: TVar (HashSet TxHash)
requested = TVar (HashSet TxHash)
rq,
myMetrics :: Maybe StoreMetrics
myMetrics = Maybe StoreMetrics
metrics
}
m Any -> (Async Any -> m a) -> m a
forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> (Async a -> m b) -> m b
withAsync (ReaderT BlockStore m Any -> BlockStore -> m Any
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Inbox BlockStoreMessage -> ReaderT BlockStore m Any
forall b. Inbox BlockStoreMessage -> ReaderT BlockStore m b
go Inbox BlockStoreMessage
inbox) BlockStore
r) ((Async Any -> m a) -> m a) -> (Async Any -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \Async Any
a -> do
Async Any -> m ()
forall (m :: * -> *) a. MonadIO m => Async a -> m ()
link Async Any
a
BlockStore -> m a
action BlockStore
r
where
go :: Inbox BlockStoreMessage -> ReaderT BlockStore m b
go Inbox BlockStoreMessage
inbox = do
ReaderT BlockStore m ()
ini
ReaderT BlockStore m ()
wipe
Inbox BlockStoreMessage -> ReaderT BlockStore m b
forall (m :: * -> *) b.
(MonadUnliftIO m, MonadLoggerIO m) =>
Inbox BlockStoreMessage -> ReaderT BlockStore m b
run Inbox BlockStoreMessage
inbox
del :: t (a, TxHash) -> m ()
del t (a, TxHash)
txs = do
$(Text -> Text -> m ()
logInfoS) Text
"BlockStore" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
Text
"Deleting " 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 (t (a, TxHash) -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t (a, TxHash)
txs)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" transactions"
t (a, TxHash) -> ((a, TxHash) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ t (a, TxHash)
txs (((a, TxHash) -> m ()) -> m ()) -> ((a, TxHash) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(a
_, TxHash
th) -> Bool -> TxHash -> m ()
forall (m :: * -> *). MonadImport m => Bool -> TxHash -> m ()
deleteUnconfirmedTx Bool
False TxHash
th
wipe_it :: [(a, TxHash)] -> ReaderT BlockStore m ()
wipe_it [(a, TxHash)]
txs = do
let ([(a, TxHash)]
txs1, [(a, TxHash)]
txs2) = Int -> [(a, TxHash)] -> ([(a, TxHash)], [(a, TxHash)])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
1000 [(a, TxHash)]
txs
Bool -> ReaderT BlockStore m () -> ReaderT BlockStore m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(a, TxHash)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(a, TxHash)]
txs1) (ReaderT BlockStore m () -> ReaderT BlockStore m ())
-> ReaderT BlockStore m () -> ReaderT BlockStore m ()
forall a b. (a -> b) -> a -> b
$
WriterT (ExceptT ImportException m) ()
-> BlockT m (Either ImportException ())
forall (m :: * -> *) a.
MonadLoggerIO m =>
WriterT (ExceptT ImportException m) a
-> BlockT m (Either ImportException a)
runImport ([(a, TxHash)] -> WriterT (ExceptT ImportException m) ()
forall (m :: * -> *) (t :: * -> *) a.
(Foldable t, MonadError ImportException m, MonadLoggerIO m,
StoreReadBase m, StoreWrite m) =>
t (a, TxHash) -> m ()
del [(a, TxHash)]
txs1) BlockT m (Either ImportException ())
-> (Either ImportException () -> ReaderT BlockStore m ())
-> ReaderT BlockStore m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left ImportException
e -> do
$(Text -> Text -> ReaderT BlockStore m ()
logErrorS) Text
"BlockStore" (Text -> ReaderT BlockStore m ())
-> Text -> ReaderT BlockStore m ()
forall a b. (a -> b) -> a -> b
$
Text
"Could not wipe mempool: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (ImportException -> String
forall a. Show a => a -> String
show ImportException
e)
ImportException -> ReaderT BlockStore m ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO ImportException
e
Right () -> [(a, TxHash)] -> ReaderT BlockStore m ()
wipe_it [(a, TxHash)]
txs2
wipe :: ReaderT BlockStore m ()
wipe
| BlockStoreConfig -> Bool
blockConfWipeMempool BlockStoreConfig
cfg =
ReaderT BlockStore m [(UnixTime, TxHash)]
forall (m :: * -> *). StoreReadBase m => m [(UnixTime, TxHash)]
getMempool ReaderT BlockStore m [(UnixTime, TxHash)]
-> ([(UnixTime, TxHash)] -> ReaderT BlockStore m ())
-> ReaderT BlockStore m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [(UnixTime, TxHash)] -> ReaderT BlockStore m ()
forall (m :: * -> *) a.
MonadLoggerIO m =>
[(a, TxHash)] -> ReaderT BlockStore m ()
wipe_it
| Bool
otherwise =
() -> ReaderT BlockStore m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
ini :: ReaderT BlockStore m ()
ini =
WriterT (ExceptT ImportException m) ()
-> BlockT m (Either ImportException ())
forall (m :: * -> *) a.
MonadLoggerIO m =>
WriterT (ExceptT ImportException m) a
-> BlockT m (Either ImportException a)
runImport WriterT (ExceptT ImportException m) ()
forall (m :: * -> *). MonadImport m => m ()
initBest BlockT m (Either ImportException ())
-> (Either ImportException () -> ReaderT BlockStore m ())
-> ReaderT BlockStore m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left ImportException
e -> do
$(Text -> Text -> ReaderT BlockStore m ()
logErrorS) Text
"BlockStore" (Text -> ReaderT BlockStore m ())
-> Text -> ReaderT BlockStore m ()
forall a b. (a -> b) -> a -> b
$
Text
"Could not initialize: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (ImportException -> String
forall a. Show a => a -> String
show ImportException
e)
ImportException -> ReaderT BlockStore m ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO ImportException
e
Right () -> () -> ReaderT BlockStore m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
run :: Inbox BlockStoreMessage -> ReaderT BlockStore m b
run Inbox BlockStoreMessage
inbox =
ReaderT BlockStore m ()
-> (Async () -> ReaderT BlockStore m b) -> ReaderT BlockStore m b
forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> (Async a -> m b) -> m b
withAsync (Mailbox BlockStoreMessage -> ReaderT BlockStore m ()
forall (m :: * -> *).
MonadLoggerIO m =>
Mailbox BlockStoreMessage -> m ()
pingMe (Inbox BlockStoreMessage -> Mailbox BlockStoreMessage
forall msg. Inbox msg -> Mailbox msg
inboxToMailbox Inbox BlockStoreMessage
inbox)) ((Async () -> ReaderT BlockStore m b) -> ReaderT BlockStore m b)
-> (Async () -> ReaderT BlockStore m b) -> ReaderT BlockStore m b
forall a b. (a -> b) -> a -> b
$
ReaderT BlockStore m b -> Async () -> ReaderT BlockStore m b
forall a b. a -> b -> a
const (ReaderT BlockStore m b -> Async () -> ReaderT BlockStore m b)
-> ReaderT BlockStore m b -> Async () -> ReaderT BlockStore m b
forall a b. (a -> b) -> a -> b
$
ReaderT BlockStore m () -> ReaderT BlockStore m b
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (ReaderT BlockStore m () -> ReaderT BlockStore m b)
-> ReaderT BlockStore m () -> ReaderT BlockStore m b
forall a b. (a -> b) -> a -> b
$
Inbox BlockStoreMessage -> ReaderT BlockStore m BlockStoreMessage
forall (mbox :: * -> *) (m :: * -> *) msg.
(InChan mbox, MonadIO m) =>
mbox msg -> m msg
receive Inbox BlockStoreMessage
inbox
ReaderT BlockStore m BlockStoreMessage
-> (BlockStoreMessage -> ReaderT BlockStore m ())
-> ReaderT BlockStore m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (BlockStore -> m ()) -> ReaderT BlockStore m ()
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((BlockStore -> m ()) -> ReaderT BlockStore m ())
-> (BlockStoreMessage -> BlockStore -> m ())
-> BlockStoreMessage
-> ReaderT BlockStore m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT BlockStore m () -> BlockStore -> m ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (ReaderT BlockStore m () -> BlockStore -> m ())
-> (BlockStoreMessage -> ReaderT BlockStore m ())
-> BlockStoreMessage
-> BlockStore
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockStoreMessage -> ReaderT BlockStore m ()
forall (m :: * -> *).
(MonadUnliftIO m, MonadLoggerIO m) =>
BlockStoreMessage -> BlockT m ()
processBlockStoreMessage
isInSync :: MonadLoggerIO m => BlockT m Bool
isInSync :: BlockT m Bool
isInSync =
ReaderT BlockStore m (Maybe BlockHash)
forall (m :: * -> *). StoreReadBase m => m (Maybe BlockHash)
getBestBlock ReaderT BlockStore m (Maybe BlockHash)
-> (Maybe BlockHash -> BlockT m Bool) -> BlockT m Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe BlockHash
Nothing -> do
$(Text -> Text -> ReaderT BlockStore m ()
logErrorS) Text
"BlockStore" Text
"Block database uninitialized"
BlockException -> BlockT m Bool
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO BlockException
Uninitialized
Just BlockHash
bb -> do
BlockNode
cb <- (BlockStore -> Chain) -> ReaderT BlockStore m Chain
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (BlockStoreConfig -> Chain
blockConfChain (BlockStoreConfig -> Chain)
-> (BlockStore -> BlockStoreConfig) -> BlockStore -> Chain
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockStore -> BlockStoreConfig
myConfig) ReaderT BlockStore m Chain
-> (Chain -> ReaderT BlockStore m BlockNode)
-> ReaderT BlockStore m BlockNode
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Chain -> ReaderT BlockStore m BlockNode
forall (m :: * -> *). MonadIO m => Chain -> m BlockNode
chainGetBest
if BlockHeader -> BlockHash
headerHash (BlockNode -> BlockHeader
nodeHeader BlockNode
cb) BlockHash -> BlockHash -> Bool
forall a. Eq a => a -> a -> Bool
== BlockHash
bb
then ReaderT BlockStore m ()
forall (m :: * -> *).
(MonadLoggerIO m, MonadReader BlockStore m) =>
m ()
clearSyncingState ReaderT BlockStore m () -> BlockT m Bool -> BlockT m Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> BlockT m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
else Bool -> BlockT m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
guardMempool :: Monad m => BlockT m () -> BlockT m ()
guardMempool :: BlockT m () -> BlockT m ()
guardMempool BlockT m ()
f = do
Bool
n <- (BlockStore -> Bool) -> ReaderT BlockStore m Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (BlockStoreConfig -> Bool
blockConfNoMempool (BlockStoreConfig -> Bool)
-> (BlockStore -> BlockStoreConfig) -> BlockStore -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockStore -> BlockStoreConfig
myConfig)
Bool -> BlockT m () -> BlockT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
n BlockT m ()
f
syncMempool :: Monad m => BlockT m () -> BlockT m ()
syncMempool :: BlockT m () -> BlockT m ()
syncMempool BlockT m ()
f = do
Bool
s <- (BlockStore -> Bool) -> ReaderT BlockStore m Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (BlockStoreConfig -> Bool
blockConfSyncMempool (BlockStoreConfig -> Bool)
-> (BlockStore -> BlockStoreConfig) -> BlockStore -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockStore -> BlockStoreConfig
myConfig)
Bool -> BlockT m () -> BlockT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
s BlockT m ()
f
mempool :: (MonadUnliftIO m, MonadLoggerIO m) => Peer -> BlockT m ()
mempool :: Peer -> BlockT m ()
mempool Peer
p =
BlockT m () -> BlockT m ()
forall (m :: * -> *). Monad m => BlockT m () -> BlockT m ()
guardMempool (BlockT m () -> BlockT m ())
-> (BlockT m () -> BlockT m ()) -> BlockT m () -> BlockT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockT m () -> BlockT m ()
forall (m :: * -> *). Monad m => BlockT m () -> BlockT m ()
syncMempool (BlockT m () -> BlockT m ()) -> BlockT m () -> BlockT m ()
forall a b. (a -> b) -> a -> b
$
BlockT m Bool
forall (m :: * -> *). MonadLoggerIO m => BlockT m Bool
isInSync BlockT m Bool -> (Bool -> BlockT m ()) -> BlockT m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
s -> Bool -> BlockT m () -> BlockT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
s (BlockT m () -> BlockT m ()) -> BlockT m () -> BlockT m ()
forall a b. (a -> b) -> a -> b
$ do
$(Text -> Text -> BlockT m ()
logDebugS) Text
"BlockStore" (Text -> BlockT m ()) -> Text -> BlockT m ()
forall a b. (a -> b) -> a -> b
$
Text
"Requesting mempool from peer: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
Message
MMempool Message -> Peer -> BlockT m ()
forall (m :: * -> *). MonadIO m => Message -> Peer -> m ()
`sendMessage` Peer
p
processBlock ::
(MonadUnliftIO m, MonadLoggerIO m) =>
Peer ->
Block ->
BlockT m ()
processBlock :: Peer -> Block -> BlockT m ()
processBlock Peer
peer Block
block = ReaderT BlockStore m (Maybe ()) -> BlockT m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT BlockStore m (Maybe ()) -> BlockT m ())
-> (MaybeT (ReaderT BlockStore m) ()
-> ReaderT BlockStore m (Maybe ()))
-> MaybeT (ReaderT BlockStore m) ()
-> BlockT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MaybeT (ReaderT BlockStore m) () -> ReaderT BlockStore m (Maybe ())
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT (ReaderT BlockStore m) () -> BlockT m ())
-> MaybeT (ReaderT BlockStore m) () -> BlockT m ()
forall a b. (a -> b) -> a -> b
$ do
Peer -> MaybeT (ReaderT BlockStore m) Bool
forall (m :: * -> *).
(MonadLoggerIO m, MonadReader BlockStore m) =>
Peer -> m Bool
checkPeer Peer
peer MaybeT (ReaderT BlockStore m) Bool
-> (Bool -> MaybeT (ReaderT BlockStore m) ())
-> MaybeT (ReaderT BlockStore m) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
True -> () -> MaybeT (ReaderT BlockStore m) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Bool
False -> do
$(Text -> Text -> MaybeT (ReaderT BlockStore m) ()
logErrorS) Text
"BlockStore" (Text -> MaybeT (ReaderT BlockStore m) ())
-> Text -> MaybeT (ReaderT BlockStore m) ()
forall a b. (a -> b) -> a -> b
$
Text
"Non-syncing peer " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
peer
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" sent me a block: "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> BlockHash -> Text
blockHashToHex BlockHash
blockhash
String -> PeerException
PeerMisbehaving String
"Sent unexpected block" PeerException -> Peer -> MaybeT (ReaderT BlockStore m) ()
forall (m :: * -> *). MonadIO m => PeerException -> Peer -> m ()
`killPeer` Peer
peer
MaybeT (ReaderT BlockStore m) ()
forall (m :: * -> *) a. MonadPlus m => m a
mzero
BlockNode
node <-
BlockHash -> MaybeT (ReaderT BlockStore m) (Maybe BlockNode)
forall (m :: * -> *).
(MonadLoggerIO m, MonadReader BlockStore m) =>
BlockHash -> m (Maybe BlockNode)
getBlockNode BlockHash
blockhash MaybeT (ReaderT BlockStore m) (Maybe BlockNode)
-> (Maybe BlockNode -> MaybeT (ReaderT BlockStore m) BlockNode)
-> MaybeT (ReaderT BlockStore m) BlockNode
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just BlockNode
b -> BlockNode -> MaybeT (ReaderT BlockStore m) BlockNode
forall (m :: * -> *) a. Monad m => a -> m a
return BlockNode
b
Maybe BlockNode
Nothing -> do
$(Text -> Text -> MaybeT (ReaderT BlockStore m) ()
logErrorS) Text
"BlockStore" (Text -> MaybeT (ReaderT BlockStore m) ())
-> Text -> MaybeT (ReaderT BlockStore m) ()
forall a b. (a -> b) -> a -> b
$
Text
"Peer " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
peer
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" sent unknown block: "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> BlockHash -> Text
blockHashToHex BlockHash
blockhash
String -> PeerException
PeerMisbehaving String
"Sent unknown block" PeerException -> Peer -> MaybeT (ReaderT BlockStore m) ()
forall (m :: * -> *). MonadIO m => PeerException -> Peer -> m ()
`killPeer` Peer
peer
MaybeT (ReaderT BlockStore m) BlockNode
forall (m :: * -> *) a. MonadPlus m => m a
mzero
$(Text -> Text -> MaybeT (ReaderT BlockStore m) ()
logDebugS) Text
"BlockStore" (Text -> MaybeT (ReaderT BlockStore m) ())
-> Text -> MaybeT (ReaderT BlockStore m) ()
forall a b. (a -> b) -> a -> b
$
Text
"Processing block: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> BlockNode -> Maybe Block -> Text
blockText BlockNode
node Maybe Block
forall a. Maybe a
Nothing
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" from peer: "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
peer
BlockT m () -> MaybeT (ReaderT BlockStore m) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (BlockT m () -> MaybeT (ReaderT BlockStore m) ())
-> (BlockT m () -> BlockT m ())
-> BlockT m ()
-> MaybeT (ReaderT BlockStore m) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Block -> BlockT m () -> BlockT m ()
forall (m :: * -> *) a.
MonadIO m =>
Maybe Block -> BlockT m a -> BlockT m a
notify (Block -> Maybe Block
forall a. a -> Maybe a
Just Block
block) (BlockT m () -> MaybeT (ReaderT BlockStore m) ())
-> BlockT m () -> MaybeT (ReaderT BlockStore m) ()
forall a b. (a -> b) -> a -> b
$
WriterT (ExceptT ImportException m) ()
-> BlockT m (Either ImportException ())
forall (m :: * -> *) a.
MonadLoggerIO m =>
WriterT (ExceptT ImportException m) a
-> BlockT m (Either ImportException a)
runImport (Block -> BlockNode -> WriterT (ExceptT ImportException m) ()
forall (m :: * -> *). MonadImport m => Block -> BlockNode -> m ()
importBlock Block
block BlockNode
node) BlockT m (Either ImportException ())
-> (Either ImportException () -> BlockT m ()) -> BlockT m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left ImportException
e -> ImportException -> BlockT m ()
forall (m :: * -> *) a.
(MonadLogger m, Show a, MonadIO m) =>
a -> m ()
failure ImportException
e
Right () -> BlockNode -> BlockT m ()
forall (m :: * -> *).
(MonadLoggerIO m, MonadUnliftIO m) =>
BlockNode -> ReaderT BlockStore m ()
success BlockNode
node
where
header :: BlockHeader
header = Block -> BlockHeader
blockHeader Block
block
blockhash :: BlockHash
blockhash = BlockHeader -> BlockHash
headerHash BlockHeader
header
hexhash :: Text
hexhash = BlockHash -> Text
blockHashToHex BlockHash
blockhash
success :: BlockNode -> ReaderT BlockStore m ()
success BlockNode
node = do
$(Text -> Text -> ReaderT BlockStore m ()
logInfoS) Text
"BlockStore" (Text -> ReaderT BlockStore m ())
-> Text -> ReaderT BlockStore m ()
forall a b. (a -> b) -> a -> b
$
Text
"Best block: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> BlockNode -> Maybe Block -> Text
blockText BlockNode
node (Block -> Maybe Block
forall a. a -> Maybe a
Just Block
block)
BlockHash -> ReaderT BlockStore m ()
forall (m :: * -> *).
(MonadReader BlockStore m, MonadIO m) =>
BlockHash -> m ()
removeSyncingBlock (BlockHash -> ReaderT BlockStore m ())
-> BlockHash -> ReaderT BlockStore m ()
forall a b. (a -> b) -> a -> b
$ BlockHeader -> BlockHash
headerHash (BlockHeader -> BlockHash) -> BlockHeader -> BlockHash
forall a b. (a -> b) -> a -> b
$ BlockNode -> BlockHeader
nodeHeader BlockNode
node
ReaderT BlockStore m ()
forall (m :: * -> *). (MonadIO m, MonadReader BlockStore m) => m ()
touchPeer
BlockT m Bool
forall (m :: * -> *). MonadLoggerIO m => BlockT m Bool
isInSync BlockT m Bool
-> (Bool -> ReaderT BlockStore m ()) -> ReaderT BlockStore m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
False -> ReaderT BlockStore m ()
forall (m :: * -> *). MonadLoggerIO m => BlockT m ()
syncMe
Bool
True -> do
ReaderT BlockStore m ()
forall (m :: * -> *).
(StoreReadBase m, MonadLoggerIO m, MonadReader BlockStore m) =>
m ()
updateOrphans
Peer -> ReaderT BlockStore m ()
forall (m :: * -> *).
(MonadUnliftIO m, MonadLoggerIO m) =>
Peer -> BlockT m ()
mempool Peer
peer
failure :: a -> m ()
failure a
e = do
$(Text -> Text -> m ()
logErrorS) Text
"BlockStore" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
Text
"Error importing block " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
hexhash
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" from peer: "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
peer
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (a -> String
forall a. Show a => a -> String
show a
e)
PeerException -> Peer -> m ()
forall (m :: * -> *). MonadIO m => PeerException -> Peer -> m ()
killPeer (String -> PeerException
PeerMisbehaving (a -> String
forall a. Show a => a -> String
show a
e)) Peer
peer
setSyncingBlocks ::
(MonadReader BlockStore m, MonadIO m) =>
[BlockHash] ->
m ()
setSyncingBlocks :: [BlockHash] -> m ()
setSyncingBlocks [BlockHash]
hs =
(BlockStore -> TVar (Maybe Syncing)) -> m (TVar (Maybe Syncing))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> TVar (Maybe Syncing)
myPeer m (TVar (Maybe Syncing)) -> (TVar (Maybe Syncing) -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \TVar (Maybe Syncing)
box ->
STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$
TVar (Maybe Syncing) -> (Maybe Syncing -> Maybe Syncing) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Maybe Syncing)
box ((Maybe Syncing -> Maybe Syncing) -> STM ())
-> (Maybe Syncing -> Maybe Syncing) -> STM ()
forall a b. (a -> b) -> a -> b
$ \case
Maybe Syncing
Nothing -> Maybe Syncing
forall a. Maybe a
Nothing
Just Syncing
x -> Syncing -> Maybe Syncing
forall a. a -> Maybe a
Just Syncing
x {syncingBlocks :: [BlockHash]
syncingBlocks = [BlockHash]
hs}
getSyncingBlocks :: (MonadReader BlockStore m, MonadIO m) => m [BlockHash]
getSyncingBlocks :: m [BlockHash]
getSyncingBlocks =
(BlockStore -> TVar (Maybe Syncing)) -> m (TVar (Maybe Syncing))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> TVar (Maybe Syncing)
myPeer m (TVar (Maybe Syncing))
-> (TVar (Maybe Syncing) -> m (Maybe Syncing)) -> m (Maybe Syncing)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TVar (Maybe Syncing) -> m (Maybe Syncing)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO m (Maybe Syncing)
-> (Maybe Syncing -> m [BlockHash]) -> m [BlockHash]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe Syncing
Nothing -> [BlockHash] -> m [BlockHash]
forall (m :: * -> *) a. Monad m => a -> m a
return []
Just Syncing
x -> [BlockHash] -> m [BlockHash]
forall (m :: * -> *) a. Monad m => a -> m a
return ([BlockHash] -> m [BlockHash]) -> [BlockHash] -> m [BlockHash]
forall a b. (a -> b) -> a -> b
$ Syncing -> [BlockHash]
syncingBlocks Syncing
x
addSyncingBlocks ::
(MonadReader BlockStore m, MonadIO m) =>
[BlockHash] ->
m ()
addSyncingBlocks :: [BlockHash] -> m ()
addSyncingBlocks [BlockHash]
hs =
(BlockStore -> TVar (Maybe Syncing)) -> m (TVar (Maybe Syncing))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> TVar (Maybe Syncing)
myPeer m (TVar (Maybe Syncing)) -> (TVar (Maybe Syncing) -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \TVar (Maybe Syncing)
box ->
STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$
TVar (Maybe Syncing) -> (Maybe Syncing -> Maybe Syncing) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Maybe Syncing)
box ((Maybe Syncing -> Maybe Syncing) -> STM ())
-> (Maybe Syncing -> Maybe Syncing) -> STM ()
forall a b. (a -> b) -> a -> b
$ \case
Maybe Syncing
Nothing -> Maybe Syncing
forall a. Maybe a
Nothing
Just Syncing
x -> Syncing -> Maybe Syncing
forall a. a -> Maybe a
Just Syncing
x {syncingBlocks :: [BlockHash]
syncingBlocks = Syncing -> [BlockHash]
syncingBlocks Syncing
x [BlockHash] -> [BlockHash] -> [BlockHash]
forall a. Semigroup a => a -> a -> a
<> [BlockHash]
hs}
removeSyncingBlock ::
(MonadReader BlockStore m, MonadIO m) =>
BlockHash ->
m ()
removeSyncingBlock :: BlockHash -> m ()
removeSyncingBlock BlockHash
h = do
TVar (Maybe Syncing)
box <- (BlockStore -> TVar (Maybe Syncing)) -> m (TVar (Maybe Syncing))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> TVar (Maybe Syncing)
myPeer
STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$
TVar (Maybe Syncing) -> (Maybe Syncing -> Maybe Syncing) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Maybe Syncing)
box ((Maybe Syncing -> Maybe Syncing) -> STM ())
-> (Maybe Syncing -> Maybe Syncing) -> STM ()
forall a b. (a -> b) -> a -> b
$ \case
Maybe Syncing
Nothing -> Maybe Syncing
forall a. Maybe a
Nothing
Just Syncing
x -> Syncing -> Maybe Syncing
forall a. a -> Maybe a
Just Syncing
x {syncingBlocks :: [BlockHash]
syncingBlocks = BlockHash -> [BlockHash] -> [BlockHash]
forall a. Eq a => a -> [a] -> [a]
delete BlockHash
h (Syncing -> [BlockHash]
syncingBlocks Syncing
x)}
checkPeer :: (MonadLoggerIO m, MonadReader BlockStore m) => Peer -> m Bool
checkPeer :: Peer -> m Bool
checkPeer Peer
p =
(Syncing -> Peer) -> Maybe Syncing -> Maybe Peer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Syncing -> Peer
syncingPeer (Maybe Syncing -> Maybe Peer)
-> m (Maybe Syncing) -> m (Maybe Peer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Maybe Syncing)
forall (m :: * -> *).
(MonadIO m, MonadReader BlockStore m) =>
m (Maybe Syncing)
getSyncingState m (Maybe Peer) -> (Maybe Peer -> m Bool) -> m Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe Peer
Nothing -> Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
Just Peer
p' -> Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ Peer
p Peer -> Peer -> Bool
forall a. Eq a => a -> a -> Bool
== Peer
p'
getBlockNode ::
(MonadLoggerIO m, MonadReader BlockStore m) =>
BlockHash ->
m (Maybe BlockNode)
getBlockNode :: BlockHash -> m (Maybe BlockNode)
getBlockNode BlockHash
blockhash =
BlockHash -> Chain -> m (Maybe BlockNode)
forall (m :: * -> *).
MonadIO m =>
BlockHash -> Chain -> m (Maybe BlockNode)
chainGetBlock BlockHash
blockhash (Chain -> m (Maybe BlockNode)) -> m Chain -> m (Maybe BlockNode)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (BlockStore -> Chain) -> m Chain
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (BlockStoreConfig -> Chain
blockConfChain (BlockStoreConfig -> Chain)
-> (BlockStore -> BlockStoreConfig) -> BlockStore -> Chain
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockStore -> BlockStoreConfig
myConfig)
processNoBlocks ::
MonadLoggerIO m =>
Peer ->
[BlockHash] ->
BlockT m ()
processNoBlocks :: Peer -> [BlockHash] -> BlockT m ()
processNoBlocks Peer
p [BlockHash]
hs = do
[(Int, BlockHash)]
-> ((Int, BlockHash) -> BlockT m ()) -> BlockT m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Int] -> [BlockHash] -> [(Int, BlockHash)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Int
1 :: Int) ..] [BlockHash]
hs) (((Int, BlockHash) -> BlockT m ()) -> BlockT m ())
-> ((Int, BlockHash) -> BlockT m ()) -> BlockT m ()
forall a b. (a -> b) -> a -> b
$ \(Int
i, BlockHash
h) ->
$(Text -> Text -> BlockT m ()
logErrorS) Text
"BlockStore" (Text -> BlockT m ()) -> Text -> BlockT m ()
forall a b. (a -> b) -> a -> b
$
Text
"Block "
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 Int
i)
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/"
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 ([BlockHash] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BlockHash]
hs))
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> BlockHash -> Text
blockHashToHex BlockHash
h
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" not found by peer: "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
PeerException -> Peer -> BlockT m ()
forall (m :: * -> *). MonadIO m => PeerException -> Peer -> m ()
killPeer (String -> PeerException
PeerMisbehaving String
"Did not find requested block(s)") Peer
p
processTx :: MonadLoggerIO m => Peer -> Tx -> BlockT m ()
processTx :: Peer -> Tx -> BlockT m ()
processTx Peer
p Tx
tx = BlockT m () -> BlockT m ()
forall (m :: * -> *). Monad m => BlockT m () -> BlockT m ()
guardMempool (BlockT m () -> BlockT m ()) -> BlockT m () -> BlockT m ()
forall a b. (a -> b) -> a -> b
$ do
UTCTime
t <- IO UTCTime -> ReaderT BlockStore m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
$(Text -> Text -> BlockT m ()
logDebugS) Text
"BlockManager" (Text -> BlockT m ()) -> Text -> BlockT m ()
forall a b. (a -> b) -> a -> b
$
Text
"Received tx " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TxHash -> Text
txHashToHex (Tx -> TxHash
txHash Tx
tx)
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" by peer: "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
PendingTx -> BlockT m ()
forall (m :: * -> *). MonadIO m => PendingTx -> BlockT m ()
addPendingTx (PendingTx -> BlockT m ()) -> PendingTx -> BlockT m ()
forall a b. (a -> b) -> a -> b
$ UTCTime -> Tx -> HashSet TxHash -> PendingTx
PendingTx UTCTime
t Tx
tx HashSet TxHash
forall a. HashSet a
HashSet.empty
pruneOrphans :: MonadIO m => BlockT m ()
pruneOrphans :: BlockT m ()
pruneOrphans = BlockT m () -> BlockT m ()
forall (m :: * -> *). Monad m => BlockT m () -> BlockT m ()
guardMempool (BlockT m () -> BlockT m ()) -> BlockT m () -> BlockT m ()
forall a b. (a -> b) -> a -> b
$ do
TVar (HashMap TxHash PendingTx)
ts <- (BlockStore -> TVar (HashMap TxHash PendingTx))
-> ReaderT BlockStore m (TVar (HashMap TxHash PendingTx))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> TVar (HashMap TxHash PendingTx)
myTxs
UTCTime
now <- IO UTCTime -> ReaderT BlockStore m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
STM () -> BlockT m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> BlockT m ())
-> ((PendingTx -> Bool) -> STM ())
-> (PendingTx -> Bool)
-> BlockT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar (HashMap TxHash PendingTx)
-> (HashMap TxHash PendingTx -> HashMap TxHash PendingTx) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (HashMap TxHash PendingTx)
ts ((HashMap TxHash PendingTx -> HashMap TxHash PendingTx) -> STM ())
-> ((PendingTx -> Bool)
-> HashMap TxHash PendingTx -> HashMap TxHash PendingTx)
-> (PendingTx -> Bool)
-> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PendingTx -> Bool)
-> HashMap TxHash PendingTx -> HashMap TxHash PendingTx
forall v k. (v -> Bool) -> HashMap k v -> HashMap k v
HashMap.filter ((PendingTx -> Bool) -> BlockT m ())
-> (PendingTx -> Bool) -> BlockT m ()
forall a b. (a -> b) -> a -> b
$ \PendingTx
p ->
UTCTime
now UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` PendingTx -> UTCTime
pendingTxTime PendingTx
p NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
> NominalDiffTime
600
addPendingTx :: MonadIO m => PendingTx -> BlockT m ()
addPendingTx :: PendingTx -> BlockT m ()
addPendingTx PendingTx
p = do
TVar (HashMap TxHash PendingTx)
ts <- (BlockStore -> TVar (HashMap TxHash PendingTx))
-> ReaderT BlockStore m (TVar (HashMap TxHash PendingTx))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> TVar (HashMap TxHash PendingTx)
myTxs
TVar (HashSet TxHash)
rq <- (BlockStore -> TVar (HashSet TxHash))
-> ReaderT BlockStore m (TVar (HashSet TxHash))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> TVar (HashSet TxHash)
requested
STM Int -> ReaderT BlockStore m Int
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Int -> ReaderT BlockStore m Int)
-> STM Int -> ReaderT BlockStore m Int
forall a b. (a -> b) -> a -> b
$ do
TVar (HashMap TxHash PendingTx)
-> (HashMap TxHash PendingTx -> HashMap TxHash PendingTx) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (HashMap TxHash PendingTx)
ts ((HashMap TxHash PendingTx -> HashMap TxHash PendingTx) -> STM ())
-> (HashMap TxHash PendingTx -> HashMap TxHash PendingTx) -> STM ()
forall a b. (a -> b) -> a -> b
$ TxHash
-> PendingTx
-> HashMap TxHash PendingTx
-> HashMap TxHash PendingTx
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert TxHash
th PendingTx
p
TVar (HashSet TxHash)
-> (HashSet TxHash -> HashSet TxHash) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (HashSet TxHash)
rq ((HashSet TxHash -> HashSet TxHash) -> STM ())
-> (HashSet TxHash -> HashSet TxHash) -> STM ()
forall a b. (a -> b) -> a -> b
$ TxHash -> HashSet TxHash -> HashSet TxHash
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HashSet.delete TxHash
th
HashMap TxHash PendingTx -> Int
forall k v. HashMap k v -> Int
HashMap.size (HashMap TxHash PendingTx -> Int)
-> STM (HashMap TxHash PendingTx) -> STM Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (HashMap TxHash PendingTx) -> STM (HashMap TxHash PendingTx)
forall a. TVar a -> STM a
readTVar TVar (HashMap TxHash PendingTx)
ts
BlockT m ()
forall (m :: * -> *). MonadIO m => BlockT m ()
setPendingTxs
where
th :: TxHash
th = Tx -> TxHash
txHash (PendingTx -> Tx
pendingTx PendingTx
p)
addRequestedTx :: MonadIO m => TxHash -> BlockT m ()
addRequestedTx :: TxHash -> BlockT m ()
addRequestedTx TxHash
th = do
TVar (HashSet TxHash)
qbox <- (BlockStore -> TVar (HashSet TxHash))
-> ReaderT BlockStore m (TVar (HashSet TxHash))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> TVar (HashSet TxHash)
requested
STM () -> BlockT m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> BlockT m ()) -> STM () -> BlockT m ()
forall a b. (a -> b) -> a -> b
$ TVar (HashSet TxHash)
-> (HashSet TxHash -> HashSet TxHash) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (HashSet TxHash)
qbox ((HashSet TxHash -> HashSet TxHash) -> STM ())
-> (HashSet TxHash -> HashSet TxHash) -> STM ()
forall a b. (a -> b) -> a -> b
$ TxHash -> HashSet TxHash -> HashSet TxHash
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HashSet.insert TxHash
th
IO () -> BlockT m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> BlockT m ()) -> (IO () -> IO ()) -> IO () -> BlockT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Async ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Async ()) -> IO ())
-> (IO () -> IO (Async ())) -> IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO (Async ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async (IO () -> BlockT m ()) -> IO () -> BlockT m ()
forall a b. (a -> b) -> a -> b
$ do
Int -> IO ()
forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay Int
20000000
STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (HashSet TxHash)
-> (HashSet TxHash -> HashSet TxHash) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (HashSet TxHash)
qbox ((HashSet TxHash -> HashSet TxHash) -> STM ())
-> (HashSet TxHash -> HashSet TxHash) -> STM ()
forall a b. (a -> b) -> a -> b
$ TxHash -> HashSet TxHash -> HashSet TxHash
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HashSet.delete TxHash
th
isPending :: MonadIO m => TxHash -> BlockT m Bool
isPending :: TxHash -> BlockT m Bool
isPending TxHash
th = do
TVar (HashMap TxHash PendingTx)
tbox <- (BlockStore -> TVar (HashMap TxHash PendingTx))
-> ReaderT BlockStore m (TVar (HashMap TxHash PendingTx))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> TVar (HashMap TxHash PendingTx)
myTxs
TVar (HashSet TxHash)
qbox <- (BlockStore -> TVar (HashSet TxHash))
-> ReaderT BlockStore m (TVar (HashSet TxHash))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> TVar (HashSet TxHash)
requested
STM Bool -> BlockT m Bool
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Bool -> BlockT m Bool) -> STM Bool -> BlockT m Bool
forall a b. (a -> b) -> a -> b
$ do
HashMap TxHash PendingTx
ts <- TVar (HashMap TxHash PendingTx) -> STM (HashMap TxHash PendingTx)
forall a. TVar a -> STM a
readTVar TVar (HashMap TxHash PendingTx)
tbox
HashSet TxHash
rs <- TVar (HashSet TxHash) -> STM (HashSet TxHash)
forall a. TVar a -> STM a
readTVar TVar (HashSet TxHash)
qbox
Bool -> STM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> STM Bool) -> Bool -> STM Bool
forall a b. (a -> b) -> a -> b
$
TxHash
th TxHash -> HashMap TxHash PendingTx -> Bool
forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool
`HashMap.member` HashMap TxHash PendingTx
ts
Bool -> Bool -> Bool
|| TxHash
th TxHash -> HashSet TxHash -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`HashSet.member` HashSet TxHash
rs
pendingTxs :: MonadIO m => Int -> BlockT m [PendingTx]
pendingTxs :: Int -> BlockT m [PendingTx]
pendingTxs Int
i = do
[PendingTx]
selected <-
(BlockStore -> TVar (HashMap TxHash PendingTx))
-> ReaderT BlockStore m (TVar (HashMap TxHash PendingTx))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> TVar (HashMap TxHash PendingTx)
myTxs ReaderT BlockStore m (TVar (HashMap TxHash PendingTx))
-> (TVar (HashMap TxHash PendingTx) -> BlockT m [PendingTx])
-> BlockT m [PendingTx]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \TVar (HashMap TxHash PendingTx)
box -> STM [PendingTx] -> BlockT m [PendingTx]
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM [PendingTx] -> BlockT m [PendingTx])
-> STM [PendingTx] -> BlockT m [PendingTx]
forall a b. (a -> b) -> a -> b
$ do
HashMap TxHash PendingTx
pending <- TVar (HashMap TxHash PendingTx) -> STM (HashMap TxHash PendingTx)
forall a. TVar a -> STM a
readTVar TVar (HashMap TxHash PendingTx)
box
let ([PendingTx]
selected, HashMap TxHash PendingTx
rest) = HashMap TxHash PendingTx -> ([PendingTx], HashMap TxHash PendingTx)
select HashMap TxHash PendingTx
pending
TVar (HashMap TxHash PendingTx)
-> HashMap TxHash PendingTx -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (HashMap TxHash PendingTx)
box HashMap TxHash PendingTx
rest
[PendingTx] -> STM [PendingTx]
forall (m :: * -> *) a. Monad m => a -> m a
return ([PendingTx]
selected)
BlockT m ()
forall (m :: * -> *). MonadIO m => BlockT m ()
setPendingTxs
[PendingTx] -> BlockT m [PendingTx]
forall (m :: * -> *) a. Monad m => a -> m a
return [PendingTx]
selected
where
select :: HashMap TxHash PendingTx -> ([PendingTx], HashMap TxHash PendingTx)
select HashMap TxHash PendingTx
pend =
let eligible :: HashMap TxHash PendingTx
eligible = (PendingTx -> Bool)
-> HashMap TxHash PendingTx -> HashMap TxHash PendingTx
forall v k. (v -> Bool) -> HashMap k v -> HashMap k v
HashMap.filter (HashSet TxHash -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (HashSet TxHash -> Bool)
-> (PendingTx -> HashSet TxHash) -> PendingTx -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PendingTx -> HashSet TxHash
pendingDeps) HashMap TxHash PendingTx
pend
orphans :: HashMap TxHash PendingTx
orphans = HashMap TxHash PendingTx
-> HashMap TxHash PendingTx -> HashMap TxHash PendingTx
forall k v w.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k w -> HashMap k v
HashMap.difference HashMap TxHash PendingTx
pend HashMap TxHash PendingTx
eligible
selected :: [PendingTx]
selected = Int -> [PendingTx] -> [PendingTx]
forall a. Int -> [a] -> [a]
take Int
i ([PendingTx] -> [PendingTx]) -> [PendingTx] -> [PendingTx]
forall a b. (a -> b) -> a -> b
$ HashMap TxHash PendingTx -> [PendingTx]
sortit HashMap TxHash PendingTx
eligible
remaining :: HashMap TxHash PendingTx
remaining = (PendingTx -> Bool)
-> HashMap TxHash PendingTx -> HashMap TxHash PendingTx
forall v k. (v -> Bool) -> HashMap k v -> HashMap k v
HashMap.filter (PendingTx -> [PendingTx] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [PendingTx]
selected) HashMap TxHash PendingTx
eligible
in ([PendingTx]
selected, HashMap TxHash PendingTx
remaining HashMap TxHash PendingTx
-> HashMap TxHash PendingTx -> HashMap TxHash PendingTx
forall a. Semigroup a => a -> a -> a
<> HashMap TxHash PendingTx
orphans)
sortit :: HashMap TxHash PendingTx -> [PendingTx]
sortit HashMap TxHash PendingTx
m =
let sorted :: [(BlockHeight, Tx)]
sorted = [Tx] -> [(BlockHeight, Tx)]
sortTxs ([Tx] -> [(BlockHeight, Tx)]) -> [Tx] -> [(BlockHeight, Tx)]
forall a b. (a -> b) -> a -> b
$ (PendingTx -> Tx) -> [PendingTx] -> [Tx]
forall a b. (a -> b) -> [a] -> [b]
map PendingTx -> Tx
pendingTx ([PendingTx] -> [Tx]) -> [PendingTx] -> [Tx]
forall a b. (a -> b) -> a -> b
$ HashMap TxHash PendingTx -> [PendingTx]
forall k v. HashMap k v -> [v]
HashMap.elems HashMap TxHash PendingTx
m
txids :: [TxHash]
txids = ((BlockHeight, Tx) -> TxHash) -> [(BlockHeight, Tx)] -> [TxHash]
forall a b. (a -> b) -> [a] -> [b]
map (Tx -> TxHash
txHash (Tx -> TxHash)
-> ((BlockHeight, Tx) -> Tx) -> (BlockHeight, Tx) -> TxHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BlockHeight, Tx) -> Tx
forall a b. (a, b) -> b
snd) [(BlockHeight, Tx)]
sorted
in (TxHash -> Maybe PendingTx) -> [TxHash] -> [PendingTx]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (TxHash -> HashMap TxHash PendingTx -> Maybe PendingTx
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
`HashMap.lookup` HashMap TxHash PendingTx
m) [TxHash]
txids
fulfillOrphans :: MonadIO m => BlockStore -> TxHash -> m ()
fulfillOrphans :: BlockStore -> TxHash -> m ()
fulfillOrphans BlockStore
block_read TxHash
th =
STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ TVar (HashMap TxHash PendingTx)
-> (HashMap TxHash PendingTx -> HashMap TxHash PendingTx) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (HashMap TxHash PendingTx)
box ((PendingTx -> PendingTx)
-> HashMap TxHash PendingTx -> HashMap TxHash PendingTx
forall v1 v2 k. (v1 -> v2) -> HashMap k v1 -> HashMap k v2
HashMap.map PendingTx -> PendingTx
fulfill)
where
box :: TVar (HashMap TxHash PendingTx)
box = BlockStore -> TVar (HashMap TxHash PendingTx)
myTxs BlockStore
block_read
fulfill :: PendingTx -> PendingTx
fulfill PendingTx
p = PendingTx
p {pendingDeps :: HashSet TxHash
pendingDeps = TxHash -> HashSet TxHash -> HashSet TxHash
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HashSet.delete TxHash
th (PendingTx -> HashSet TxHash
pendingDeps PendingTx
p)}
updateOrphans ::
( StoreReadBase m,
MonadLoggerIO m,
MonadReader BlockStore m
) =>
m ()
updateOrphans :: m ()
updateOrphans = do
TVar (HashMap TxHash PendingTx)
box <- (BlockStore -> TVar (HashMap TxHash PendingTx))
-> m (TVar (HashMap TxHash PendingTx))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> TVar (HashMap TxHash PendingTx)
myTxs
HashMap TxHash PendingTx
pending <- TVar (HashMap TxHash PendingTx) -> m (HashMap TxHash PendingTx)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar (HashMap TxHash PendingTx)
box
let orphans :: HashMap TxHash PendingTx
orphans = (PendingTx -> Bool)
-> HashMap TxHash PendingTx -> HashMap TxHash PendingTx
forall v k. (v -> Bool) -> HashMap k v -> HashMap k v
HashMap.filter (Bool -> Bool
not (Bool -> Bool) -> (PendingTx -> Bool) -> PendingTx -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashSet TxHash -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (HashSet TxHash -> Bool)
-> (PendingTx -> HashSet TxHash) -> PendingTx -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PendingTx -> HashSet TxHash
pendingDeps) HashMap TxHash PendingTx
pending
HashMap TxHash (Maybe PendingTx)
updated <- HashMap TxHash PendingTx
-> (PendingTx -> m (Maybe PendingTx))
-> m (HashMap TxHash (Maybe PendingTx))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM HashMap TxHash PendingTx
orphans ((PendingTx -> m (Maybe PendingTx))
-> m (HashMap TxHash (Maybe PendingTx)))
-> (PendingTx -> m (Maybe PendingTx))
-> m (HashMap TxHash (Maybe PendingTx))
forall a b. (a -> b) -> a -> b
$ \PendingTx
p -> do
let tx :: Tx
tx = PendingTx -> Tx
pendingTx PendingTx
p
TxHash -> m Bool
forall (m :: * -> *). StoreReadBase m => TxHash -> m Bool
exists (Tx -> TxHash
txHash Tx
tx) m Bool -> (Bool -> m (Maybe PendingTx)) -> m (Maybe PendingTx)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
True -> Maybe PendingTx -> m (Maybe PendingTx)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe PendingTx
forall a. Maybe a
Nothing
Bool
False -> PendingTx -> Maybe PendingTx
forall a. a -> Maybe a
Just (PendingTx -> Maybe PendingTx)
-> m PendingTx -> m (Maybe PendingTx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PendingTx -> m PendingTx
forall (m :: * -> *). StoreReadBase m => PendingTx -> m PendingTx
fill_deps PendingTx
p
let pruned :: HashMap TxHash PendingTx
pruned = (Maybe PendingTx -> PendingTx)
-> HashMap TxHash (Maybe PendingTx) -> HashMap TxHash PendingTx
forall v1 v2 k. (v1 -> v2) -> HashMap k v1 -> HashMap k v2
HashMap.map Maybe PendingTx -> PendingTx
forall a. HasCallStack => Maybe a -> a
fromJust (HashMap TxHash (Maybe PendingTx) -> HashMap TxHash PendingTx)
-> HashMap TxHash (Maybe PendingTx) -> HashMap TxHash PendingTx
forall a b. (a -> b) -> a -> b
$ (Maybe PendingTx -> Bool)
-> HashMap TxHash (Maybe PendingTx)
-> HashMap TxHash (Maybe PendingTx)
forall v k. (v -> Bool) -> HashMap k v -> HashMap k v
HashMap.filter Maybe PendingTx -> Bool
forall a. Maybe a -> Bool
isJust HashMap TxHash (Maybe PendingTx)
updated
STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ TVar (HashMap TxHash PendingTx)
-> HashMap TxHash PendingTx -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (HashMap TxHash PendingTx)
box HashMap TxHash PendingTx
pruned
where
exists :: TxHash -> m Bool
exists TxHash
th =
TxHash -> m (Maybe TxData)
forall (m :: * -> *). StoreReadBase m => TxHash -> m (Maybe TxData)
getTxData TxHash
th m (Maybe TxData) -> (Maybe TxData -> m Bool) -> m Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe TxData
Nothing -> Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
Just TxData {txDataDeleted :: TxData -> Bool
txDataDeleted = Bool
True} -> Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
Just TxData {txDataDeleted :: TxData -> Bool
txDataDeleted = Bool
False} -> Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
prev_utxos :: Tx -> f [Unspent]
prev_utxos Tx
tx = [Maybe Unspent] -> [Unspent]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Unspent] -> [Unspent]) -> f [Maybe Unspent] -> f [Unspent]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TxIn -> f (Maybe Unspent)) -> [TxIn] -> f [Maybe Unspent]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (OutPoint -> f (Maybe Unspent)
forall (m :: * -> *).
StoreReadBase m =>
OutPoint -> m (Maybe Unspent)
getUnspent (OutPoint -> f (Maybe Unspent))
-> (TxIn -> OutPoint) -> TxIn -> f (Maybe Unspent)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxIn -> OutPoint
prevOutput) (Tx -> [TxIn]
txIn Tx
tx)
fulfill :: PendingTx -> Unspent -> PendingTx
fulfill PendingTx
p Unspent
unspent =
let unspent_hash :: TxHash
unspent_hash = OutPoint -> TxHash
outPointHash (Unspent -> OutPoint
unspentPoint Unspent
unspent)
new_deps :: HashSet TxHash
new_deps = TxHash -> HashSet TxHash -> HashSet TxHash
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HashSet.delete TxHash
unspent_hash (PendingTx -> HashSet TxHash
pendingDeps PendingTx
p)
in PendingTx
p {pendingDeps :: HashSet TxHash
pendingDeps = HashSet TxHash
new_deps}
fill_deps :: PendingTx -> m PendingTx
fill_deps PendingTx
p = do
let tx :: Tx
tx = PendingTx -> Tx
pendingTx PendingTx
p
[Unspent]
unspents <- Tx -> m [Unspent]
forall (f :: * -> *). StoreReadBase f => Tx -> f [Unspent]
prev_utxos Tx
tx
PendingTx -> m PendingTx
forall (m :: * -> *) a. Monad m => a -> m a
return (PendingTx -> m PendingTx) -> PendingTx -> m PendingTx
forall a b. (a -> b) -> a -> b
$ (PendingTx -> Unspent -> PendingTx)
-> PendingTx -> [Unspent] -> PendingTx
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl PendingTx -> Unspent -> PendingTx
fulfill PendingTx
p [Unspent]
unspents
newOrphanTx ::
MonadLoggerIO m =>
BlockStore ->
UTCTime ->
Tx ->
WriterT m ()
newOrphanTx :: BlockStore -> UTCTime -> Tx -> WriterT m ()
newOrphanTx BlockStore
block_read UTCTime
time Tx
tx = do
$(Text -> Text -> WriterT m ()
logDebugS) Text
"BlockStore" (Text -> WriterT m ()) -> Text -> WriterT m ()
forall a b. (a -> b) -> a -> b
$
Text
"Import tx "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TxHash -> Text
txHashToHex (Tx -> TxHash
txHash Tx
tx)
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": Orphan"
let box :: TVar (HashMap TxHash PendingTx)
box = BlockStore -> TVar (HashMap TxHash PendingTx)
myTxs BlockStore
block_read
[Unspent]
unspents <- [Maybe Unspent] -> [Unspent]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Unspent] -> [Unspent])
-> ReaderT Writer m [Maybe Unspent] -> ReaderT Writer m [Unspent]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (OutPoint -> ReaderT Writer m (Maybe Unspent))
-> [OutPoint] -> ReaderT Writer m [Maybe Unspent]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM OutPoint -> ReaderT Writer m (Maybe Unspent)
forall (m :: * -> *).
StoreReadBase m =>
OutPoint -> m (Maybe Unspent)
getUnspent [OutPoint]
prevs
let unspent_set :: HashSet OutPoint
unspent_set = [OutPoint] -> HashSet OutPoint
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HashSet.fromList ((Unspent -> OutPoint) -> [Unspent] -> [OutPoint]
forall a b. (a -> b) -> [a] -> [b]
map Unspent -> OutPoint
unspentPoint [Unspent]
unspents)
missing_set :: HashSet OutPoint
missing_set = HashSet OutPoint -> HashSet OutPoint -> HashSet OutPoint
forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
HashSet.difference HashSet OutPoint
prev_set HashSet OutPoint
unspent_set
missing_txs :: HashSet TxHash
missing_txs = (OutPoint -> TxHash) -> HashSet OutPoint -> HashSet TxHash
forall b a.
(Hashable b, Eq b) =>
(a -> b) -> HashSet a -> HashSet b
HashSet.map OutPoint -> TxHash
outPointHash HashSet OutPoint
missing_set
STM () -> WriterT m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> WriterT m ())
-> ((HashMap TxHash PendingTx -> HashMap TxHash PendingTx)
-> STM ())
-> (HashMap TxHash PendingTx -> HashMap TxHash PendingTx)
-> WriterT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar (HashMap TxHash PendingTx)
-> (HashMap TxHash PendingTx -> HashMap TxHash PendingTx) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (HashMap TxHash PendingTx)
box ((HashMap TxHash PendingTx -> HashMap TxHash PendingTx)
-> WriterT m ())
-> (HashMap TxHash PendingTx -> HashMap TxHash PendingTx)
-> WriterT m ()
forall a b. (a -> b) -> a -> b
$
TxHash
-> PendingTx
-> HashMap TxHash PendingTx
-> HashMap TxHash PendingTx
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert
(Tx -> TxHash
txHash Tx
tx)
PendingTx :: UTCTime -> Tx -> HashSet TxHash -> PendingTx
PendingTx
{ pendingTxTime :: UTCTime
pendingTxTime = UTCTime
time,
pendingTx :: Tx
pendingTx = Tx
tx,
pendingDeps :: HashSet TxHash
pendingDeps = HashSet TxHash
missing_txs
}
where
prev_set :: HashSet OutPoint
prev_set = [OutPoint] -> HashSet OutPoint
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HashSet.fromList [OutPoint]
prevs
prevs :: [OutPoint]
prevs = (TxIn -> OutPoint) -> [TxIn] -> [OutPoint]
forall a b. (a -> b) -> [a] -> [b]
map TxIn -> OutPoint
prevOutput (Tx -> [TxIn]
txIn Tx
tx)
importMempoolTx ::
(MonadLoggerIO m, MonadError ImportException m) =>
BlockStore ->
UTCTime ->
Tx ->
WriterT m Bool
importMempoolTx :: BlockStore -> UTCTime -> Tx -> WriterT m Bool
importMempoolTx BlockStore
block_read UTCTime
time Tx
tx =
WriterT m Bool
-> (ImportException -> WriterT m Bool) -> WriterT m Bool
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError WriterT m Bool
new_mempool_tx ImportException -> WriterT m Bool
forall (m :: * -> *).
MonadLoggerIO m =>
ImportException -> ReaderT Writer m Bool
handle_error
where
tx_hash :: TxHash
tx_hash = Tx -> TxHash
txHash Tx
tx
handle_error :: ImportException -> ReaderT Writer m Bool
handle_error ImportException
Orphan = do
BlockStore -> UTCTime -> Tx -> WriterT m ()
forall (m :: * -> *).
MonadLoggerIO m =>
BlockStore -> UTCTime -> Tx -> WriterT m ()
newOrphanTx BlockStore
block_read UTCTime
time Tx
tx
Bool -> ReaderT Writer m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
handle_error ImportException
_ = Bool -> ReaderT Writer m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
seconds :: UnixTime
seconds = NominalDiffTime -> UnixTime
forall a b. (RealFrac a, Integral b) => a -> b
floor (UTCTime -> NominalDiffTime
utcTimeToPOSIXSeconds UTCTime
time)
new_mempool_tx :: WriterT m Bool
new_mempool_tx =
Tx -> UnixTime -> WriterT m Bool
forall (m :: * -> *). MonadImport m => Tx -> UnixTime -> m Bool
newMempoolTx Tx
tx UnixTime
seconds WriterT m Bool -> (Bool -> WriterT m Bool) -> WriterT m Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
True -> do
$(Text -> Text -> ReaderT Writer m ()
logInfoS) Text
"BlockStore" (Text -> ReaderT Writer m ()) -> Text -> ReaderT Writer m ()
forall a b. (a -> b) -> a -> b
$
Text
"Import tx " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TxHash -> Text
txHashToHex (Tx -> TxHash
txHash Tx
tx)
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": OK"
BlockStore -> TxHash -> ReaderT Writer m ()
forall (m :: * -> *). MonadIO m => BlockStore -> TxHash -> m ()
fulfillOrphans BlockStore
block_read TxHash
tx_hash
Bool -> WriterT m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
Bool
False -> do
$(Text -> Text -> ReaderT Writer m ()
logDebugS) Text
"BlockStore" (Text -> ReaderT Writer m ()) -> Text -> ReaderT Writer m ()
forall a b. (a -> b) -> a -> b
$
Text
"Import tx " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TxHash -> Text
txHashToHex (Tx -> TxHash
txHash Tx
tx)
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": Already imported"
Bool -> WriterT m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
notify :: MonadIO m => Maybe Block -> BlockT m a -> BlockT m a
notify :: Maybe Block -> BlockT m a -> BlockT m a
notify Maybe Block
block BlockT m a
go = do
HashSet TxHash
old <- HashSet TxHash -> HashSet TxHash -> HashSet TxHash
forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
HashSet.union HashSet TxHash
e (HashSet TxHash -> HashSet TxHash)
-> ([(UnixTime, TxHash)] -> HashSet TxHash)
-> [(UnixTime, TxHash)]
-> HashSet TxHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TxHash] -> HashSet TxHash
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HashSet.fromList ([TxHash] -> HashSet TxHash)
-> ([(UnixTime, TxHash)] -> [TxHash])
-> [(UnixTime, TxHash)]
-> HashSet TxHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((UnixTime, TxHash) -> TxHash) -> [(UnixTime, TxHash)] -> [TxHash]
forall a b. (a -> b) -> [a] -> [b]
map (UnixTime, TxHash) -> TxHash
forall a b. (a, b) -> b
snd ([(UnixTime, TxHash)] -> HashSet TxHash)
-> ReaderT BlockStore m [(UnixTime, TxHash)]
-> ReaderT BlockStore m (HashSet TxHash)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT BlockStore m [(UnixTime, TxHash)]
forall (m :: * -> *). StoreReadBase m => m [(UnixTime, TxHash)]
getMempool
a
x <- BlockT m a
go
HashSet TxHash
new <- HashSet TxHash -> HashSet TxHash -> HashSet TxHash
forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
HashSet.union HashSet TxHash
e (HashSet TxHash -> HashSet TxHash)
-> ([(UnixTime, TxHash)] -> HashSet TxHash)
-> [(UnixTime, TxHash)]
-> HashSet TxHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TxHash] -> HashSet TxHash
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HashSet.fromList ([TxHash] -> HashSet TxHash)
-> ([(UnixTime, TxHash)] -> [TxHash])
-> [(UnixTime, TxHash)]
-> HashSet TxHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((UnixTime, TxHash) -> TxHash) -> [(UnixTime, TxHash)] -> [TxHash]
forall a b. (a -> b) -> [a] -> [b]
map (UnixTime, TxHash) -> TxHash
forall a b. (a, b) -> b
snd ([(UnixTime, TxHash)] -> HashSet TxHash)
-> ReaderT BlockStore m [(UnixTime, TxHash)]
-> ReaderT BlockStore m (HashSet TxHash)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT BlockStore m [(UnixTime, TxHash)]
forall (m :: * -> *). StoreReadBase m => m [(UnixTime, TxHash)]
getMempool
Publisher StoreEvent
l <- (BlockStore -> Publisher StoreEvent)
-> ReaderT BlockStore m (Publisher StoreEvent)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (BlockStoreConfig -> Publisher StoreEvent
blockConfListener (BlockStoreConfig -> Publisher StoreEvent)
-> (BlockStore -> BlockStoreConfig)
-> BlockStore
-> Publisher StoreEvent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockStore -> BlockStoreConfig
myConfig)
HashSet TxHash
-> (TxHash -> ReaderT BlockStore m ()) -> ReaderT BlockStore m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (HashSet TxHash
old HashSet TxHash -> HashSet TxHash -> HashSet TxHash
forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
`HashSet.difference` HashSet TxHash
new) ((TxHash -> ReaderT BlockStore m ()) -> ReaderT BlockStore m ())
-> (TxHash -> ReaderT BlockStore m ()) -> ReaderT BlockStore m ()
forall a b. (a -> b) -> a -> b
$ \TxHash
h ->
StoreEvent -> Publisher StoreEvent -> ReaderT BlockStore m ()
forall (m :: * -> *) msg. MonadIO m => msg -> Publisher msg -> m ()
publish (TxHash -> StoreEvent
StoreMempoolDelete TxHash
h) Publisher StoreEvent
l
HashSet TxHash
-> (TxHash -> ReaderT BlockStore m ()) -> ReaderT BlockStore m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (HashSet TxHash
new HashSet TxHash -> HashSet TxHash -> HashSet TxHash
forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
`HashSet.difference` HashSet TxHash
old) ((TxHash -> ReaderT BlockStore m ()) -> ReaderT BlockStore m ())
-> (TxHash -> ReaderT BlockStore m ()) -> ReaderT BlockStore m ()
forall a b. (a -> b) -> a -> b
$ \TxHash
h ->
StoreEvent -> Publisher StoreEvent -> ReaderT BlockStore m ()
forall (m :: * -> *) msg. MonadIO m => msg -> Publisher msg -> m ()
publish (TxHash -> StoreEvent
StoreMempoolNew TxHash
h) Publisher StoreEvent
l
case Maybe Block
block of
Just Block
b -> StoreEvent -> Publisher StoreEvent -> ReaderT BlockStore m ()
forall (m :: * -> *) msg. MonadIO m => msg -> Publisher msg -> m ()
publish (BlockHash -> StoreEvent
StoreBestBlock (BlockHeader -> BlockHash
headerHash (Block -> BlockHeader
blockHeader Block
b))) Publisher StoreEvent
l
Maybe Block
Nothing -> () -> ReaderT BlockStore m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
a -> BlockT m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
where
e :: HashSet TxHash
e = case Maybe Block
block of
Just Block
b -> [TxHash] -> HashSet TxHash
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HashSet.fromList ((Tx -> TxHash) -> [Tx] -> [TxHash]
forall a b. (a -> b) -> [a] -> [b]
map Tx -> TxHash
txHash (Block -> [Tx]
blockTxns Block
b))
Maybe Block
Nothing -> HashSet TxHash
forall a. HashSet a
HashSet.empty
processMempool :: MonadLoggerIO m => BlockT m ()
processMempool :: BlockT m ()
processMempool = BlockT m () -> BlockT m ()
forall (m :: * -> *). Monad m => BlockT m () -> BlockT m ()
guardMempool (BlockT m () -> BlockT m ())
-> (BlockT m () -> BlockT m ()) -> BlockT m () -> BlockT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Block -> BlockT m () -> BlockT m ()
forall (m :: * -> *) a.
MonadIO m =>
Maybe Block -> BlockT m a -> BlockT m a
notify Maybe Block
forall a. Maybe a
Nothing (BlockT m () -> BlockT m ()) -> BlockT m () -> BlockT m ()
forall a b. (a -> b) -> a -> b
$ do
[PendingTx]
txs <- Int -> BlockT m [PendingTx]
forall (m :: * -> *). MonadIO m => Int -> BlockT m [PendingTx]
pendingTxs Int
2000
BlockStore
block_read <- ReaderT BlockStore m BlockStore
forall r (m :: * -> *). MonadReader r m => m r
ask
Bool -> BlockT m () -> BlockT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([PendingTx] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PendingTx]
txs) (BlockStore -> [PendingTx] -> BlockT m ()
forall (m :: * -> *) (t :: * -> *).
(Traversable t, MonadLoggerIO m) =>
BlockStore -> t PendingTx -> ReaderT BlockStore m ()
import_txs BlockStore
block_read [PendingTx]
txs)
where
run_import :: BlockStore -> PendingTx -> WriterT m Bool
run_import BlockStore
block_read PendingTx
p =
let t :: Tx
t = PendingTx -> Tx
pendingTx PendingTx
p
h :: TxHash
h = Tx -> TxHash
txHash Tx
t
in BlockStore -> UTCTime -> Tx -> WriterT m Bool
forall (m :: * -> *).
(MonadLoggerIO m, MonadError ImportException m) =>
BlockStore -> UTCTime -> Tx -> WriterT m Bool
importMempoolTx BlockStore
block_read (PendingTx -> UTCTime
pendingTxTime PendingTx
p) (PendingTx -> Tx
pendingTx PendingTx
p)
import_txs :: BlockStore -> t PendingTx -> ReaderT BlockStore m ()
import_txs BlockStore
block_read t PendingTx
txs =
let r :: ReaderT Writer (ExceptT ImportException m) (t Bool)
r = (PendingTx -> ReaderT Writer (ExceptT ImportException m) Bool)
-> t PendingTx
-> ReaderT Writer (ExceptT ImportException m) (t Bool)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (BlockStore
-> PendingTx -> ReaderT Writer (ExceptT ImportException m) Bool
forall (m :: * -> *).
(MonadLoggerIO m, MonadError ImportException m) =>
BlockStore -> PendingTx -> WriterT m Bool
run_import BlockStore
block_read) t PendingTx
txs
in ReaderT Writer (ExceptT ImportException m) (t Bool)
-> BlockT m (Either ImportException (t Bool))
forall (m :: * -> *) a.
MonadLoggerIO m =>
WriterT (ExceptT ImportException m) a
-> BlockT m (Either ImportException a)
runImport ReaderT Writer (ExceptT ImportException m) (t Bool)
r BlockT m (Either ImportException (t Bool))
-> (Either ImportException (t Bool) -> ReaderT BlockStore m ())
-> ReaderT BlockStore m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left ImportException
e -> ImportException -> ReaderT BlockStore m ()
forall (m :: * -> *) e b.
(MonadLogger m, MonadIO m, Exception e) =>
e -> m b
report_error ImportException
e
Right t Bool
_ -> () -> ReaderT BlockStore m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
report_error :: e -> m b
report_error e
e = do
$(Text -> Text -> m ()
logErrorS) Text
"BlockImport" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
Text
"Error processing mempool: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (e -> String
forall a. Show a => a -> String
show e
e)
e -> m b
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO e
e
processTxs ::
MonadLoggerIO m =>
Peer ->
[TxHash] ->
BlockT m ()
processTxs :: Peer -> [TxHash] -> BlockT m ()
processTxs Peer
p [TxHash]
hs = BlockT m () -> BlockT m ()
forall (m :: * -> *). Monad m => BlockT m () -> BlockT m ()
guardMempool (BlockT m () -> BlockT m ()) -> BlockT m () -> BlockT m ()
forall a b. (a -> b) -> a -> b
$ do
Bool
s <- BlockT m Bool
forall (m :: * -> *). MonadLoggerIO m => BlockT m Bool
isInSync
Bool -> BlockT m () -> BlockT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
s (BlockT m () -> BlockT m ()) -> BlockT m () -> BlockT m ()
forall a b. (a -> b) -> a -> b
$ do
$(Text -> Text -> BlockT m ()
logDebugS) Text
"BlockStore" (Text -> BlockT m ()) -> Text -> BlockT m ()
forall a b. (a -> b) -> a -> b
$
Text
"Received inventory with "
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 ([TxHash] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TxHash]
hs))
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" transactions from peer: "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
[TxHash]
xs <- [Maybe TxHash] -> [TxHash]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe TxHash] -> [TxHash])
-> ReaderT BlockStore m [Maybe TxHash]
-> ReaderT BlockStore m [TxHash]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> TxHash -> ReaderT BlockStore m (Maybe TxHash))
-> ReaderT BlockStore m [Maybe TxHash]
forall b.
(Int -> TxHash -> ReaderT BlockStore m b)
-> ReaderT BlockStore m [b]
zip_counter Int -> TxHash -> ReaderT BlockStore m (Maybe TxHash)
forall (m :: * -> *) a.
(MonadIO m, MonadLogger m, Show a) =>
a -> TxHash -> ReaderT BlockStore m (Maybe TxHash)
process_tx
Bool -> BlockT m () -> BlockT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([TxHash] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TxHash]
xs) (BlockT m () -> BlockT m ()) -> BlockT m () -> BlockT m ()
forall a b. (a -> b) -> a -> b
$ [TxHash] -> BlockT m ()
forall (m :: * -> *).
MonadIO m =>
[TxHash] -> ReaderT BlockStore m ()
go [TxHash]
xs
where
len :: Int
len = [TxHash] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TxHash]
hs
zip_counter :: (Int -> TxHash -> ReaderT BlockStore m b)
-> ReaderT BlockStore m [b]
zip_counter = [(Int, TxHash)]
-> ((Int, TxHash) -> ReaderT BlockStore m b)
-> ReaderT BlockStore m [b]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([Int] -> [TxHash] -> [(Int, TxHash)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Int
1 :: Int) ..] [TxHash]
hs) (((Int, TxHash) -> ReaderT BlockStore m b)
-> ReaderT BlockStore m [b])
-> ((Int -> TxHash -> ReaderT BlockStore m b)
-> (Int, TxHash) -> ReaderT BlockStore m b)
-> (Int -> TxHash -> ReaderT BlockStore m b)
-> ReaderT BlockStore m [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> TxHash -> ReaderT BlockStore m b)
-> (Int, TxHash) -> ReaderT BlockStore m b
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry
process_tx :: a -> TxHash -> ReaderT BlockStore m (Maybe TxHash)
process_tx a
i TxHash
h =
TxHash -> BlockT m Bool
forall (m :: * -> *). MonadIO m => TxHash -> BlockT m Bool
isPending TxHash
h BlockT m Bool
-> (Bool -> ReaderT BlockStore m (Maybe TxHash))
-> ReaderT BlockStore m (Maybe TxHash)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
True -> do
$(Text -> Text -> ReaderT BlockStore m ()
logDebugS) Text
"BlockStore" (Text -> ReaderT BlockStore m ())
-> Text -> ReaderT BlockStore m ()
forall a b. (a -> b) -> a -> b
$
Text
"Tx " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (a -> String
forall a. Show a => a -> String
show a
i) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" 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 Int
len)
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TxHash -> Text
txHashToHex TxHash
h
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"Pending"
Maybe TxHash -> ReaderT BlockStore m (Maybe TxHash)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe TxHash
forall a. Maybe a
Nothing
Bool
False ->
TxHash -> ReaderT BlockStore m (Maybe TxData)
forall (m :: * -> *). StoreReadBase m => TxHash -> m (Maybe TxData)
getActiveTxData TxHash
h ReaderT BlockStore m (Maybe TxData)
-> (Maybe TxData -> ReaderT BlockStore m (Maybe TxHash))
-> ReaderT BlockStore m (Maybe TxHash)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just TxData
_ -> do
$(Text -> Text -> ReaderT BlockStore m ()
logDebugS) Text
"BlockStore" (Text -> ReaderT BlockStore m ())
-> Text -> ReaderT BlockStore m ()
forall a b. (a -> b) -> a -> b
$
Text
"Tx " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (a -> String
forall a. Show a => a -> String
show a
i) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" 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 Int
len)
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TxHash -> Text
txHashToHex TxHash
h
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"Already Imported"
Maybe TxHash -> ReaderT BlockStore m (Maybe TxHash)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe TxHash
forall a. Maybe a
Nothing
Maybe TxData
Nothing -> do
$(Text -> Text -> ReaderT BlockStore m ()
logDebugS) Text
"BlockStore" (Text -> ReaderT BlockStore m ())
-> Text -> ReaderT BlockStore m ()
forall a b. (a -> b) -> a -> b
$
Text
"Tx " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (a -> String
forall a. Show a => a -> String
show a
i) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" 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 Int
len)
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TxHash -> Text
txHashToHex TxHash
h
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"Requesting"
Maybe TxHash -> ReaderT BlockStore m (Maybe TxHash)
forall (m :: * -> *) a. Monad m => a -> m a
return (TxHash -> Maybe TxHash
forall a. a -> Maybe a
Just TxHash
h)
go :: [TxHash] -> ReaderT BlockStore m ()
go [TxHash]
xs = do
(TxHash -> ReaderT BlockStore m ())
-> [TxHash] -> ReaderT BlockStore m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ TxHash -> ReaderT BlockStore m ()
forall (m :: * -> *). MonadIO m => TxHash -> BlockT m ()
addRequestedTx [TxHash]
xs
Network
net <- (BlockStore -> Network) -> ReaderT BlockStore m Network
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (BlockStoreConfig -> Network
blockConfNet (BlockStoreConfig -> Network)
-> (BlockStore -> BlockStoreConfig) -> BlockStore -> Network
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockStore -> BlockStoreConfig
myConfig)
let inv :: InvType
inv = if Network -> Bool
getSegWit Network
net then InvType
InvWitnessTx else InvType
InvTx
vec :: [InvVector]
vec = (TxHash -> InvVector) -> [TxHash] -> [InvVector]
forall a b. (a -> b) -> [a] -> [b]
map (InvType -> Hash256 -> InvVector
InvVector InvType
inv (Hash256 -> InvVector)
-> (TxHash -> Hash256) -> TxHash -> InvVector
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxHash -> Hash256
getTxHash) [TxHash]
xs
msg :: Message
msg = GetData -> Message
MGetData ([InvVector] -> GetData
GetData [InvVector]
vec)
Message
msg Message -> Peer -> ReaderT BlockStore m ()
forall (m :: * -> *). MonadIO m => Message -> Peer -> m ()
`sendMessage` Peer
p
touchPeer ::
( MonadIO m,
MonadReader BlockStore m
) =>
m ()
touchPeer :: m ()
touchPeer =
m (Maybe Syncing)
forall (m :: * -> *).
(MonadIO m, MonadReader BlockStore m) =>
m (Maybe Syncing)
getSyncingState m (Maybe Syncing) -> (Maybe Syncing -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe Syncing
Nothing -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Syncing
_ -> do
TVar (Maybe Syncing)
box <- (BlockStore -> TVar (Maybe Syncing)) -> m (TVar (Maybe Syncing))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> TVar (Maybe Syncing)
myPeer
UTCTime
now <- IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$
TVar (Maybe Syncing) -> (Maybe Syncing -> Maybe Syncing) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Maybe Syncing)
box ((Maybe Syncing -> Maybe Syncing) -> STM ())
-> (Maybe Syncing -> Maybe Syncing) -> STM ()
forall a b. (a -> b) -> a -> b
$
(Syncing -> Syncing) -> Maybe Syncing -> Maybe Syncing
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Syncing -> Syncing) -> Maybe Syncing -> Maybe Syncing)
-> (Syncing -> Syncing) -> Maybe Syncing -> Maybe Syncing
forall a b. (a -> b) -> a -> b
$ \Syncing
x -> Syncing
x {syncingTime :: UTCTime
syncingTime = UTCTime
now}
checkTime :: MonadLoggerIO m => BlockT m ()
checkTime :: BlockT m ()
checkTime =
(BlockStore -> TVar (Maybe Syncing))
-> ReaderT BlockStore m (TVar (Maybe Syncing))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> TVar (Maybe Syncing)
myPeer ReaderT BlockStore m (TVar (Maybe Syncing))
-> (TVar (Maybe Syncing) -> ReaderT BlockStore m (Maybe Syncing))
-> ReaderT BlockStore m (Maybe Syncing)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TVar (Maybe Syncing) -> ReaderT BlockStore m (Maybe Syncing)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO ReaderT BlockStore m (Maybe Syncing)
-> (Maybe Syncing -> BlockT m ()) -> BlockT m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe Syncing
Nothing -> () -> BlockT m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just
Syncing
{ syncingTime :: Syncing -> UTCTime
syncingTime = UTCTime
t,
syncingPeer :: Syncing -> Peer
syncingPeer = Peer
p
} -> do
UTCTime
now <- IO UTCTime -> ReaderT BlockStore m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
NominalDiffTime
peer_time_out <- (BlockStore -> NominalDiffTime)
-> ReaderT BlockStore m NominalDiffTime
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (BlockStoreConfig -> NominalDiffTime
blockConfPeerTimeout (BlockStoreConfig -> NominalDiffTime)
-> (BlockStore -> BlockStoreConfig)
-> BlockStore
-> NominalDiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockStore -> BlockStoreConfig
myConfig)
Bool -> BlockT m () -> BlockT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (UTCTime
now UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` UTCTime
t NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
> NominalDiffTime
peer_time_out) (BlockT m () -> BlockT m ()) -> BlockT m () -> BlockT m ()
forall a b. (a -> b) -> a -> b
$ do
$(Text -> Text -> BlockT m ()
logErrorS) Text
"BlockStore" (Text -> BlockT m ()) -> Text -> BlockT m ()
forall a b. (a -> b) -> a -> b
$
Text
"Syncing peer timeout: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
PeerException -> Peer -> BlockT m ()
forall (m :: * -> *). MonadIO m => PeerException -> Peer -> m ()
killPeer PeerException
PeerTimeout Peer
p
revertToMainChain :: MonadLoggerIO m => BlockT m ()
revertToMainChain :: BlockT m ()
revertToMainChain = do
BlockHash
h <- BlockHeader -> BlockHash
headerHash (BlockHeader -> BlockHash)
-> (BlockNode -> BlockHeader) -> BlockNode -> BlockHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockNode -> BlockHeader
nodeHeader (BlockNode -> BlockHash)
-> ReaderT BlockStore m BlockNode -> ReaderT BlockStore m BlockHash
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT BlockStore m BlockNode
forall (m :: * -> *). MonadLoggerIO m => BlockT m BlockNode
getBest
Chain
ch <- (BlockStore -> Chain) -> ReaderT BlockStore m Chain
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (BlockStoreConfig -> Chain
blockConfChain (BlockStoreConfig -> Chain)
-> (BlockStore -> BlockStoreConfig) -> BlockStore -> Chain
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockStore -> BlockStoreConfig
myConfig)
BlockHash -> Chain -> ReaderT BlockStore m Bool
forall (m :: * -> *). MonadIO m => BlockHash -> Chain -> m Bool
chainBlockMain BlockHash
h Chain
ch ReaderT BlockStore m Bool -> (Bool -> BlockT m ()) -> BlockT m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
x -> Bool -> BlockT m () -> BlockT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
x (BlockT m () -> BlockT m ()) -> BlockT m () -> BlockT m ()
forall a b. (a -> b) -> a -> b
$ do
$(Text -> Text -> BlockT m ()
logWarnS) Text
"BlockStore" (Text -> BlockT m ()) -> Text -> BlockT m ()
forall a b. (a -> b) -> a -> b
$
Text
"Reverting best block: "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> BlockHash -> Text
blockHashToHex BlockHash
h
WriterT (ExceptT ImportException m) ()
-> BlockT m (Either ImportException ())
forall (m :: * -> *) a.
MonadLoggerIO m =>
WriterT (ExceptT ImportException m) a
-> BlockT m (Either ImportException a)
runImport (BlockHash -> WriterT (ExceptT ImportException m) ()
forall (m :: * -> *). MonadImport m => BlockHash -> m ()
revertBlock BlockHash
h) BlockT m (Either ImportException ())
-> (Either ImportException () -> BlockT m ()) -> BlockT m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left ImportException
e -> do
$(Text -> Text -> BlockT m ()
logErrorS) Text
"BlockStore" (Text -> BlockT m ()) -> Text -> BlockT m ()
forall a b. (a -> b) -> a -> b
$
Text
"Could not revert block "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> BlockHash -> Text
blockHashToHex BlockHash
h
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (ImportException -> String
forall a. Show a => a -> String
show ImportException
e)
ImportException -> BlockT m ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO ImportException
e
Right () -> [BlockHash] -> BlockT m ()
forall (m :: * -> *).
(MonadReader BlockStore m, MonadIO m) =>
[BlockHash] -> m ()
setSyncingBlocks []
BlockT m ()
forall (m :: * -> *). MonadLoggerIO m => BlockT m ()
revertToMainChain
getBest :: MonadLoggerIO m => BlockT m BlockNode
getBest :: BlockT m BlockNode
getBest = do
BlockHash
bb <-
ReaderT BlockStore m (Maybe BlockHash)
forall (m :: * -> *). StoreReadBase m => m (Maybe BlockHash)
getBestBlock ReaderT BlockStore m (Maybe BlockHash)
-> (Maybe BlockHash -> ReaderT BlockStore m BlockHash)
-> ReaderT BlockStore m BlockHash
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just BlockHash
b -> BlockHash -> ReaderT BlockStore m BlockHash
forall (m :: * -> *) a. Monad m => a -> m a
return BlockHash
b
Maybe BlockHash
Nothing -> do
$(Text -> Text -> ReaderT BlockStore m ()
logErrorS) Text
"BlockStore" Text
"No best block set"
BlockException -> ReaderT BlockStore m BlockHash
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO BlockException
Uninitialized
Chain
ch <- (BlockStore -> Chain) -> ReaderT BlockStore m Chain
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (BlockStoreConfig -> Chain
blockConfChain (BlockStoreConfig -> Chain)
-> (BlockStore -> BlockStoreConfig) -> BlockStore -> Chain
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockStore -> BlockStoreConfig
myConfig)
BlockHash -> Chain -> ReaderT BlockStore m (Maybe BlockNode)
forall (m :: * -> *).
MonadIO m =>
BlockHash -> Chain -> m (Maybe BlockNode)
chainGetBlock BlockHash
bb Chain
ch ReaderT BlockStore m (Maybe BlockNode)
-> (Maybe BlockNode -> BlockT m BlockNode) -> BlockT m BlockNode
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just BlockNode
x -> BlockNode -> BlockT m BlockNode
forall (m :: * -> *) a. Monad m => a -> m a
return BlockNode
x
Maybe BlockNode
Nothing -> do
$(Text -> Text -> ReaderT BlockStore m ()
logErrorS) Text
"BlockStore" (Text -> ReaderT BlockStore m ())
-> Text -> ReaderT BlockStore m ()
forall a b. (a -> b) -> a -> b
$
Text
"Header not found for best block: "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> BlockHash -> Text
blockHashToHex BlockHash
bb
BlockException -> BlockT m BlockNode
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (BlockHash -> BlockException
BlockNotInChain BlockHash
bb)
getSyncBest :: MonadLoggerIO m => BlockT m BlockNode
getSyncBest :: BlockT m BlockNode
getSyncBest = do
BlockHash
bb <-
ReaderT BlockStore m [BlockHash]
forall (m :: * -> *).
(MonadReader BlockStore m, MonadIO m) =>
m [BlockHash]
getSyncingBlocks ReaderT BlockStore m [BlockHash]
-> ([BlockHash] -> ReaderT BlockStore m BlockHash)
-> ReaderT BlockStore m BlockHash
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
[] ->
ReaderT BlockStore m (Maybe BlockHash)
forall (m :: * -> *). StoreReadBase m => m (Maybe BlockHash)
getBestBlock ReaderT BlockStore m (Maybe BlockHash)
-> (Maybe BlockHash -> ReaderT BlockStore m BlockHash)
-> ReaderT BlockStore m BlockHash
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just BlockHash
b -> BlockHash -> ReaderT BlockStore m BlockHash
forall (m :: * -> *) a. Monad m => a -> m a
return BlockHash
b
Maybe BlockHash
Nothing -> do
$(Text -> Text -> ReaderT BlockStore m ()
logErrorS) Text
"BlockStore" Text
"No best block set"
BlockException -> ReaderT BlockStore m BlockHash
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO BlockException
Uninitialized
[BlockHash]
hs -> BlockHash -> ReaderT BlockStore m BlockHash
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockHash -> ReaderT BlockStore m BlockHash)
-> BlockHash -> ReaderT BlockStore m BlockHash
forall a b. (a -> b) -> a -> b
$ [BlockHash] -> BlockHash
forall a. [a] -> a
last [BlockHash]
hs
Chain
ch <- (BlockStore -> Chain) -> ReaderT BlockStore m Chain
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (BlockStoreConfig -> Chain
blockConfChain (BlockStoreConfig -> Chain)
-> (BlockStore -> BlockStoreConfig) -> BlockStore -> Chain
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockStore -> BlockStoreConfig
myConfig)
BlockHash -> Chain -> ReaderT BlockStore m (Maybe BlockNode)
forall (m :: * -> *).
MonadIO m =>
BlockHash -> Chain -> m (Maybe BlockNode)
chainGetBlock BlockHash
bb Chain
ch ReaderT BlockStore m (Maybe BlockNode)
-> (Maybe BlockNode -> BlockT m BlockNode) -> BlockT m BlockNode
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just BlockNode
x -> BlockNode -> BlockT m BlockNode
forall (m :: * -> *) a. Monad m => a -> m a
return BlockNode
x
Maybe BlockNode
Nothing -> do
$(Text -> Text -> ReaderT BlockStore m ()
logErrorS) Text
"BlockStore" (Text -> ReaderT BlockStore m ())
-> Text -> ReaderT BlockStore m ()
forall a b. (a -> b) -> a -> b
$
Text
"Header not found for block: "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> BlockHash -> Text
blockHashToHex BlockHash
bb
BlockException -> BlockT m BlockNode
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (BlockHash -> BlockException
BlockNotInChain BlockHash
bb)
shouldSync :: MonadLoggerIO m => BlockT m (Maybe Peer)
shouldSync :: BlockT m (Maybe Peer)
shouldSync =
BlockT m Bool
forall (m :: * -> *). MonadLoggerIO m => BlockT m Bool
isInSync BlockT m Bool
-> (Bool -> BlockT m (Maybe Peer)) -> BlockT m (Maybe Peer)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
True -> Maybe Peer -> BlockT m (Maybe Peer)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Peer
forall a. Maybe a
Nothing
Bool
False ->
ReaderT BlockStore m (Maybe Syncing)
forall (m :: * -> *).
(MonadIO m, MonadReader BlockStore m) =>
m (Maybe Syncing)
getSyncingState ReaderT BlockStore m (Maybe Syncing)
-> (Maybe Syncing -> BlockT m (Maybe Peer))
-> BlockT m (Maybe Peer)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe Syncing
Nothing -> Maybe Peer -> BlockT m (Maybe Peer)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Peer
forall a. Maybe a
Nothing
Just Syncing {syncingPeer :: Syncing -> Peer
syncingPeer = Peer
p, syncingBlocks :: Syncing -> [BlockHash]
syncingBlocks = [BlockHash]
bs}
| Int
100 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> [BlockHash] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BlockHash]
bs -> Maybe Peer -> BlockT m (Maybe Peer)
forall (m :: * -> *) a. Monad m => a -> m a
return (Peer -> Maybe Peer
forall a. a -> Maybe a
Just Peer
p)
| Bool
otherwise -> Maybe Peer -> BlockT m (Maybe Peer)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Peer
forall a. Maybe a
Nothing
syncMe :: MonadLoggerIO m => BlockT m ()
syncMe :: BlockT m ()
syncMe = do
BlockT m ()
forall (m :: * -> *). MonadLoggerIO m => BlockT m ()
revertToMainChain
BlockT m (Maybe Peer)
forall (m :: * -> *). MonadLoggerIO m => BlockT m (Maybe Peer)
shouldSync BlockT m (Maybe Peer) -> (Maybe Peer -> BlockT m ()) -> BlockT m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe Peer
Nothing -> () -> BlockT m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Peer
p -> do
BlockNode
bb <- BlockT m BlockNode
forall (m :: * -> *). MonadLoggerIO m => BlockT m BlockNode
getSyncBest
BlockNode
bh <- BlockT m BlockNode
getbh
Bool -> BlockT m () -> BlockT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BlockNode
bb BlockNode -> BlockNode -> Bool
forall a. Eq a => a -> a -> Bool
/= BlockNode
bh) (BlockT m () -> BlockT m ()) -> BlockT m () -> BlockT m ()
forall a b. (a -> b) -> a -> b
$ do
[BlockNode]
bns <- BlockNode -> BlockNode -> ReaderT BlockStore m [BlockNode]
forall (m :: * -> *).
(MonadLoggerIO m, MonadReader BlockStore m) =>
BlockNode -> BlockNode -> m [BlockNode]
sel BlockNode
bb BlockNode
bh
[InvVector]
iv <- [BlockNode] -> ReaderT BlockStore m [InvVector]
forall (m :: * -> *).
MonadReader BlockStore m =>
[BlockNode] -> m [InvVector]
getiv [BlockNode]
bns
$(Text -> Text -> BlockT m ()
logDebugS) Text
"BlockStore" (Text -> BlockT m ()) -> Text -> BlockT m ()
forall a b. (a -> b) -> a -> b
$
Text
"Requesting "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. IsString a => String -> a
fromString (Int -> String
forall a. Show a => a -> String
show ([InvVector] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [InvVector]
iv))
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" blocks from peer: "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
[BlockHash] -> BlockT m ()
forall (m :: * -> *).
(MonadReader BlockStore m, MonadIO m) =>
[BlockHash] -> m ()
addSyncingBlocks ([BlockHash] -> BlockT m ()) -> [BlockHash] -> BlockT m ()
forall a b. (a -> b) -> a -> b
$ (BlockNode -> BlockHash) -> [BlockNode] -> [BlockHash]
forall a b. (a -> b) -> [a] -> [b]
map (BlockHeader -> BlockHash
headerHash (BlockHeader -> BlockHash)
-> (BlockNode -> BlockHeader) -> BlockNode -> BlockHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockNode -> BlockHeader
nodeHeader) [BlockNode]
bns
GetData -> Message
MGetData ([InvVector] -> GetData
GetData [InvVector]
iv) Message -> Peer -> BlockT m ()
forall (m :: * -> *). MonadIO m => Message -> Peer -> m ()
`sendMessage` Peer
p
where
getiv :: [BlockNode] -> m [InvVector]
getiv [BlockNode]
bns = do
Bool
w <- Network -> Bool
getSegWit (Network -> Bool) -> m Network -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (BlockStore -> Network) -> m Network
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (BlockStoreConfig -> Network
blockConfNet (BlockStoreConfig -> Network)
-> (BlockStore -> BlockStoreConfig) -> BlockStore -> Network
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockStore -> BlockStoreConfig
myConfig)
let i :: InvType
i = if Bool
w then InvType
InvWitnessBlock else InvType
InvBlock
f :: BlockNode -> InvVector
f = InvType -> Hash256 -> InvVector
InvVector InvType
i (Hash256 -> InvVector)
-> (BlockNode -> Hash256) -> BlockNode -> InvVector
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockHash -> Hash256
getBlockHash (BlockHash -> Hash256)
-> (BlockNode -> BlockHash) -> BlockNode -> Hash256
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockHeader -> BlockHash
headerHash (BlockHeader -> BlockHash)
-> (BlockNode -> BlockHeader) -> BlockNode -> BlockHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockNode -> BlockHeader
nodeHeader
[InvVector] -> m [InvVector]
forall (m :: * -> *) a. Monad m => a -> m a
return ([InvVector] -> m [InvVector]) -> [InvVector] -> m [InvVector]
forall a b. (a -> b) -> a -> b
$ (BlockNode -> InvVector) -> [BlockNode] -> [InvVector]
forall a b. (a -> b) -> [a] -> [b]
map BlockNode -> InvVector
f [BlockNode]
bns
getbh :: BlockT m BlockNode
getbh =
Chain -> BlockT m BlockNode
forall (m :: * -> *). MonadIO m => Chain -> m BlockNode
chainGetBest (Chain -> BlockT m BlockNode)
-> ReaderT BlockStore m Chain -> BlockT m BlockNode
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (BlockStore -> Chain) -> ReaderT BlockStore m Chain
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (BlockStoreConfig -> Chain
blockConfChain (BlockStoreConfig -> Chain)
-> (BlockStore -> BlockStoreConfig) -> BlockStore -> Chain
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockStore -> BlockStoreConfig
myConfig)
sel :: BlockNode -> BlockNode -> m [BlockNode]
sel BlockNode
bb BlockNode
bh = do
let sh :: BlockHeight
sh = BlockNode -> BlockNode -> BlockHeight
geth BlockNode
bb BlockNode
bh
BlockNode
t <- BlockHeight -> BlockNode -> m BlockNode
forall (m :: * -> *).
(MonadLoggerIO m, MonadReader BlockStore m) =>
BlockHeight -> BlockNode -> m BlockNode
top BlockHeight
sh BlockNode
bh
Chain
ch <- (BlockStore -> Chain) -> m Chain
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (BlockStoreConfig -> Chain
blockConfChain (BlockStoreConfig -> Chain)
-> (BlockStore -> BlockStoreConfig) -> BlockStore -> Chain
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockStore -> BlockStoreConfig
myConfig)
[BlockNode]
ps <- BlockHeight -> BlockNode -> Chain -> m [BlockNode]
forall (m :: * -> *).
MonadIO m =>
BlockHeight -> BlockNode -> Chain -> m [BlockNode]
chainGetParents (BlockNode -> BlockHeight
nodeHeight BlockNode
bb BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
+ BlockHeight
1) BlockNode
t Chain
ch
[BlockNode] -> m [BlockNode]
forall (m :: * -> *) a. Monad m => a -> m a
return ([BlockNode] -> m [BlockNode]) -> [BlockNode] -> m [BlockNode]
forall a b. (a -> b) -> a -> b
$
if Int
500 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> [BlockNode] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BlockNode]
ps
then [BlockNode]
ps [BlockNode] -> [BlockNode] -> [BlockNode]
forall a. Semigroup a => a -> a -> a
<> [BlockNode
bh]
else [BlockNode]
ps
geth :: BlockNode -> BlockNode -> BlockHeight
geth BlockNode
bb BlockNode
bh =
BlockHeight -> BlockHeight -> BlockHeight
forall a. Ord a => a -> a -> a
min
(BlockNode -> BlockHeight
nodeHeight BlockNode
bb BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
+ BlockHeight
501)
(BlockNode -> BlockHeight
nodeHeight BlockNode
bh)
top :: BlockHeight -> BlockNode -> m BlockNode
top BlockHeight
sh BlockNode
bh =
if BlockHeight
sh BlockHeight -> BlockHeight -> Bool
forall a. Eq a => a -> a -> Bool
== BlockNode -> BlockHeight
nodeHeight BlockNode
bh
then BlockNode -> m BlockNode
forall (m :: * -> *) a. Monad m => a -> m a
return BlockNode
bh
else BlockHeight -> BlockNode -> m BlockNode
forall (m :: * -> *).
(MonadLoggerIO m, MonadReader BlockStore m) =>
BlockHeight -> BlockNode -> m BlockNode
findAncestor BlockHeight
sh BlockNode
bh
findAncestor ::
(MonadLoggerIO m, MonadReader BlockStore m) =>
BlockHeight ->
BlockNode ->
m BlockNode
findAncestor :: BlockHeight -> BlockNode -> m BlockNode
findAncestor BlockHeight
height BlockNode
target = do
Chain
ch <- (BlockStore -> Chain) -> m Chain
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (BlockStoreConfig -> Chain
blockConfChain (BlockStoreConfig -> Chain)
-> (BlockStore -> BlockStoreConfig) -> BlockStore -> Chain
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockStore -> BlockStoreConfig
myConfig)
BlockHeight -> BlockNode -> Chain -> m (Maybe BlockNode)
forall (m :: * -> *).
MonadIO m =>
BlockHeight -> BlockNode -> Chain -> m (Maybe BlockNode)
chainGetAncestor BlockHeight
height BlockNode
target Chain
ch m (Maybe BlockNode)
-> (Maybe BlockNode -> m BlockNode) -> m BlockNode
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just BlockNode
ancestor -> BlockNode -> m BlockNode
forall (m :: * -> *) a. Monad m => a -> m a
return BlockNode
ancestor
Maybe BlockNode
Nothing -> do
let h :: BlockHash
h = BlockHeader -> BlockHash
headerHash (BlockHeader -> BlockHash) -> BlockHeader -> BlockHash
forall a b. (a -> b) -> a -> b
$ BlockNode -> BlockHeader
nodeHeader BlockNode
target
$(Text -> Text -> m ()
logErrorS) Text
"BlockStore" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
Text
"Could not find header for ancestor of block "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> BlockHash -> Text
blockHashToHex BlockHash
h
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" at height "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (BlockHeight -> String
forall a. Show a => a -> String
show (BlockNode -> BlockHeight
nodeHeight BlockNode
target))
BlockException -> m BlockNode
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (BlockException -> m BlockNode) -> BlockException -> m BlockNode
forall a b. (a -> b) -> a -> b
$ BlockHeight -> BlockHash -> BlockException
AncestorNotInChain BlockHeight
height BlockHash
h
finishPeer ::
(MonadLoggerIO m, MonadReader BlockStore m) =>
Peer ->
m ()
finishPeer :: Peer -> m ()
finishPeer Peer
p = do
TVar (Maybe Syncing)
box <- (BlockStore -> TVar (Maybe Syncing)) -> m (TVar (Maybe Syncing))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> TVar (Maybe Syncing)
myPeer
TVar (Maybe Syncing) -> m (Maybe Syncing)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar (Maybe Syncing)
box m (Maybe Syncing) -> (Maybe Syncing -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just Syncing {syncingPeer :: Syncing -> Peer
syncingPeer = Peer
p'} | Peer
p Peer -> Peer -> Bool
forall a. Eq a => a -> a -> Bool
== Peer
p' -> TVar (Maybe Syncing) -> m ()
forall (m :: * -> *) a.
(MonadIO m, MonadLogger m) =>
TVar (Maybe a) -> m ()
reset_it TVar (Maybe Syncing)
box
Maybe Syncing
_ -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
reset_it :: TVar (Maybe a) -> m ()
reset_it TVar (Maybe a)
box = do
STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ TVar (Maybe a) -> Maybe a -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe a)
box Maybe a
forall a. Maybe a
Nothing
$(Text -> Text -> m ()
logDebugS) Text
"BlockStore" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Releasing peer: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
Peer -> m ()
forall (m :: * -> *). MonadIO m => Peer -> m ()
setFree Peer
p
trySetPeer :: MonadLoggerIO m => Peer -> BlockT m Bool
trySetPeer :: Peer -> BlockT m Bool
trySetPeer Peer
p =
ReaderT BlockStore m (Maybe Syncing)
forall (m :: * -> *).
(MonadIO m, MonadReader BlockStore m) =>
m (Maybe Syncing)
getSyncingState ReaderT BlockStore m (Maybe Syncing)
-> (Maybe Syncing -> BlockT m Bool) -> BlockT m Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just Syncing
_ -> Bool -> BlockT m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
Maybe Syncing
Nothing -> BlockT m Bool
set_it
where
set_it :: BlockT m Bool
set_it =
Peer -> BlockT m Bool
forall (m :: * -> *). MonadIO m => Peer -> m Bool
setBusy Peer
p BlockT m Bool -> (Bool -> BlockT m Bool) -> BlockT m Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
False -> Bool -> BlockT m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
Bool
True -> do
$(Text -> Text -> ReaderT BlockStore m ()
logDebugS) Text
"BlockStore" (Text -> ReaderT BlockStore m ())
-> Text -> ReaderT BlockStore m ()
forall a b. (a -> b) -> a -> b
$
Text
"Locked peer: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
TVar (Maybe Syncing)
box <- (BlockStore -> TVar (Maybe Syncing))
-> ReaderT BlockStore m (TVar (Maybe Syncing))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> TVar (Maybe Syncing)
myPeer
UTCTime
now <- IO UTCTime -> ReaderT BlockStore m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
STM () -> ReaderT BlockStore m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ReaderT BlockStore m ())
-> (Maybe Syncing -> STM ())
-> Maybe Syncing
-> ReaderT BlockStore m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar (Maybe Syncing) -> Maybe Syncing -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe Syncing)
box (Maybe Syncing -> ReaderT BlockStore m ())
-> Maybe Syncing -> ReaderT BlockStore m ()
forall a b. (a -> b) -> a -> b
$
Syncing -> Maybe Syncing
forall a. a -> Maybe a
Just
Syncing :: Peer -> UTCTime -> [BlockHash] -> Syncing
Syncing
{ syncingPeer :: Peer
syncingPeer = Peer
p,
syncingTime :: UTCTime
syncingTime = UTCTime
now,
syncingBlocks :: [BlockHash]
syncingBlocks = []
}
Bool -> BlockT m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
trySyncing :: MonadLoggerIO m => BlockT m ()
trySyncing :: BlockT m ()
trySyncing =
BlockT m Bool
forall (m :: * -> *). MonadLoggerIO m => BlockT m Bool
isInSync BlockT m Bool -> (Bool -> BlockT m ()) -> BlockT m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
True -> () -> BlockT m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Bool
False ->
ReaderT BlockStore m (Maybe Syncing)
forall (m :: * -> *).
(MonadIO m, MonadReader BlockStore m) =>
m (Maybe Syncing)
getSyncingState ReaderT BlockStore m (Maybe Syncing)
-> (Maybe Syncing -> BlockT m ()) -> BlockT m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just Syncing
_ -> () -> BlockT m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Maybe Syncing
Nothing -> BlockT m ()
online_peer
where
recurse :: [Peer] -> ReaderT BlockStore m ()
recurse [] = () -> ReaderT BlockStore m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
recurse (Peer
p : [Peer]
ps) =
Peer -> BlockT m Bool
forall (m :: * -> *). MonadLoggerIO m => Peer -> BlockT m Bool
trySetPeer Peer
p BlockT m Bool
-> (Bool -> ReaderT BlockStore m ()) -> ReaderT BlockStore m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
False -> [Peer] -> ReaderT BlockStore m ()
recurse [Peer]
ps
Bool
True -> ReaderT BlockStore m ()
forall (m :: * -> *). MonadLoggerIO m => BlockT m ()
syncMe
online_peer :: BlockT m ()
online_peer = do
[OnlinePeer]
ops <- PeerManager -> ReaderT BlockStore m [OnlinePeer]
forall (m :: * -> *). MonadIO m => PeerManager -> m [OnlinePeer]
getPeers (PeerManager -> ReaderT BlockStore m [OnlinePeer])
-> ReaderT BlockStore m PeerManager
-> ReaderT BlockStore m [OnlinePeer]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (BlockStore -> PeerManager) -> ReaderT BlockStore m PeerManager
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (BlockStoreConfig -> PeerManager
blockConfManager (BlockStoreConfig -> PeerManager)
-> (BlockStore -> BlockStoreConfig) -> BlockStore -> PeerManager
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockStore -> BlockStoreConfig
myConfig)
let ps :: [Peer]
ps = (OnlinePeer -> Peer) -> [OnlinePeer] -> [Peer]
forall a b. (a -> b) -> [a] -> [b]
map OnlinePeer -> Peer
onlinePeerMailbox [OnlinePeer]
ops
[Peer] -> BlockT m ()
forall (m :: * -> *).
MonadLoggerIO m =>
[Peer] -> ReaderT BlockStore m ()
recurse [Peer]
ps
trySyncingPeer :: (MonadUnliftIO m, MonadLoggerIO m) => Peer -> BlockT m ()
trySyncingPeer :: Peer -> BlockT m ()
trySyncingPeer Peer
p =
BlockT m Bool
forall (m :: * -> *). MonadLoggerIO m => BlockT m Bool
isInSync BlockT m Bool -> (Bool -> BlockT m ()) -> BlockT m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
True -> Peer -> BlockT m ()
forall (m :: * -> *).
(MonadUnliftIO m, MonadLoggerIO m) =>
Peer -> BlockT m ()
mempool Peer
p
Bool
False ->
Peer -> BlockT m Bool
forall (m :: * -> *). MonadLoggerIO m => Peer -> BlockT m Bool
trySetPeer Peer
p BlockT m Bool -> (Bool -> BlockT m ()) -> BlockT m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
False -> () -> BlockT m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Bool
True -> BlockT m ()
forall (m :: * -> *). MonadLoggerIO m => BlockT m ()
syncMe
getSyncingState ::
(MonadIO m, MonadReader BlockStore m) => m (Maybe Syncing)
getSyncingState :: m (Maybe Syncing)
getSyncingState =
TVar (Maybe Syncing) -> m (Maybe Syncing)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (TVar (Maybe Syncing) -> m (Maybe Syncing))
-> m (TVar (Maybe Syncing)) -> m (Maybe Syncing)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (BlockStore -> TVar (Maybe Syncing)) -> m (TVar (Maybe Syncing))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> TVar (Maybe Syncing)
myPeer
clearSyncingState ::
(MonadLoggerIO m, MonadReader BlockStore m) => m ()
clearSyncingState :: m ()
clearSyncingState =
(BlockStore -> TVar (Maybe Syncing)) -> m (TVar (Maybe Syncing))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> TVar (Maybe Syncing)
myPeer m (TVar (Maybe Syncing))
-> (TVar (Maybe Syncing) -> m (Maybe Syncing)) -> m (Maybe Syncing)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TVar (Maybe Syncing) -> m (Maybe Syncing)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO m (Maybe Syncing) -> (Maybe Syncing -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe Syncing
Nothing -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Syncing {syncingPeer :: Syncing -> Peer
syncingPeer = Peer
p} -> Peer -> m ()
forall (m :: * -> *).
(MonadLoggerIO m, MonadReader BlockStore m) =>
Peer -> m ()
finishPeer Peer
p
processBlockStoreMessage ::
(MonadUnliftIO m, MonadLoggerIO m) =>
BlockStoreMessage ->
BlockT m ()
processBlockStoreMessage :: BlockStoreMessage -> BlockT m ()
processBlockStoreMessage (BlockNewBest BlockNode
_) =
BlockT m ()
forall (m :: * -> *). MonadLoggerIO m => BlockT m ()
trySyncing
processBlockStoreMessage (BlockPeerConnect Peer
p) =
Peer -> BlockT m ()
forall (m :: * -> *).
(MonadUnliftIO m, MonadLoggerIO m) =>
Peer -> BlockT m ()
trySyncingPeer Peer
p
processBlockStoreMessage (BlockPeerDisconnect Peer
p) =
Peer -> BlockT m ()
forall (m :: * -> *).
(MonadLoggerIO m, MonadReader BlockStore m) =>
Peer -> m ()
finishPeer Peer
p
processBlockStoreMessage (BlockReceived Peer
p Block
b) =
Peer -> Block -> BlockT m ()
forall (m :: * -> *).
(MonadUnliftIO m, MonadLoggerIO m) =>
Peer -> Block -> BlockT m ()
processBlock Peer
p Block
b
processBlockStoreMessage (BlockNotFound Peer
p [BlockHash]
bs) =
Peer -> [BlockHash] -> BlockT m ()
forall (m :: * -> *).
MonadLoggerIO m =>
Peer -> [BlockHash] -> BlockT m ()
processNoBlocks Peer
p [BlockHash]
bs
processBlockStoreMessage (TxRefReceived Peer
p Tx
tx) =
Peer -> Tx -> BlockT m ()
forall (m :: * -> *). MonadLoggerIO m => Peer -> Tx -> BlockT m ()
processTx Peer
p Tx
tx
processBlockStoreMessage (TxRefAvailable Peer
p [TxHash]
ts) =
Peer -> [TxHash] -> BlockT m ()
forall (m :: * -> *).
MonadLoggerIO m =>
Peer -> [TxHash] -> BlockT m ()
processTxs Peer
p [TxHash]
ts
processBlockStoreMessage (BlockPing Listen ()
r) = do
BlockT m ()
forall (m :: * -> *). MonadIO m => BlockT m ()
setStoreHeight
BlockT m ()
forall (m :: * -> *). MonadIO m => BlockT m ()
setHeadersHeight
BlockT m ()
forall (m :: * -> *). MonadIO m => BlockT m ()
setPendingTxs
BlockT m ()
forall (m :: * -> *). MonadIO m => BlockT m ()
setPeersConnected
BlockT m ()
forall (m :: * -> *). MonadIO m => BlockT m ()
setMempoolSize
BlockT m ()
forall (m :: * -> *). MonadLoggerIO m => BlockT m ()
trySyncing
BlockT m ()
forall (m :: * -> *). MonadLoggerIO m => BlockT m ()
processMempool
BlockT m ()
forall (m :: * -> *). MonadIO m => BlockT m ()
pruneOrphans
BlockT m ()
forall (m :: * -> *). MonadLoggerIO m => BlockT m ()
checkTime
STM () -> BlockT m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (Listen ()
r ())
pingMe :: MonadLoggerIO m => Mailbox BlockStoreMessage -> m ()
pingMe :: Mailbox BlockStoreMessage -> m ()
pingMe Mailbox BlockStoreMessage
mbox =
m () -> m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
Listen () -> BlockStoreMessage
BlockPing (Listen () -> BlockStoreMessage)
-> Mailbox BlockStoreMessage -> m ()
forall (m :: * -> *) (mbox :: * -> *) response request.
(MonadIO m, OutChan mbox) =>
(Listen response -> request) -> mbox request -> m response
`query` Mailbox BlockStoreMessage
mbox
Int
delay <-
IO Int -> m Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> m Int) -> IO Int -> m Int
forall a b. (a -> b) -> a -> b
$
(Int, Int) -> IO Int
forall a (m :: * -> *). (Random a, MonadIO m) => (a, a) -> m a
randomRIO
( Int
100 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000,
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
blockStorePeerConnect :: MonadIO m => Peer -> BlockStore -> m ()
blockStorePeerConnect :: Peer -> BlockStore -> m ()
blockStorePeerConnect Peer
peer BlockStore
store =
Peer -> BlockStoreMessage
BlockPeerConnect Peer
peer BlockStoreMessage -> Mailbox BlockStoreMessage -> m ()
forall (m :: * -> *) (mbox :: * -> *) msg.
(MonadIO m, OutChan mbox) =>
msg -> mbox msg -> m ()
`send` BlockStore -> Mailbox BlockStoreMessage
myMailbox BlockStore
store
blockStorePeerDisconnect ::
MonadIO m => Peer -> BlockStore -> m ()
blockStorePeerDisconnect :: Peer -> BlockStore -> m ()
blockStorePeerDisconnect Peer
peer BlockStore
store =
Peer -> BlockStoreMessage
BlockPeerDisconnect Peer
peer BlockStoreMessage -> Mailbox BlockStoreMessage -> m ()
forall (m :: * -> *) (mbox :: * -> *) msg.
(MonadIO m, OutChan mbox) =>
msg -> mbox msg -> m ()
`send` BlockStore -> Mailbox BlockStoreMessage
myMailbox BlockStore
store
blockStoreHead ::
MonadIO m => BlockNode -> BlockStore -> m ()
blockStoreHead :: BlockNode -> BlockStore -> m ()
blockStoreHead BlockNode
node BlockStore
store =
BlockNode -> BlockStoreMessage
BlockNewBest BlockNode
node BlockStoreMessage -> Mailbox BlockStoreMessage -> m ()
forall (m :: * -> *) (mbox :: * -> *) msg.
(MonadIO m, OutChan mbox) =>
msg -> mbox msg -> m ()
`send` BlockStore -> Mailbox BlockStoreMessage
myMailbox BlockStore
store
blockStoreBlock ::
MonadIO m => Peer -> Block -> BlockStore -> m ()
blockStoreBlock :: Peer -> Block -> BlockStore -> m ()
blockStoreBlock Peer
peer Block
block BlockStore
store =
Peer -> Block -> BlockStoreMessage
BlockReceived Peer
peer Block
block BlockStoreMessage -> Mailbox BlockStoreMessage -> m ()
forall (m :: * -> *) (mbox :: * -> *) msg.
(MonadIO m, OutChan mbox) =>
msg -> mbox msg -> m ()
`send` BlockStore -> Mailbox BlockStoreMessage
myMailbox BlockStore
store
blockStoreNotFound ::
MonadIO m => Peer -> [BlockHash] -> BlockStore -> m ()
blockStoreNotFound :: Peer -> [BlockHash] -> BlockStore -> m ()
blockStoreNotFound Peer
peer [BlockHash]
blocks BlockStore
store =
Peer -> [BlockHash] -> BlockStoreMessage
BlockNotFound Peer
peer [BlockHash]
blocks BlockStoreMessage -> Mailbox BlockStoreMessage -> m ()
forall (m :: * -> *) (mbox :: * -> *) msg.
(MonadIO m, OutChan mbox) =>
msg -> mbox msg -> m ()
`send` BlockStore -> Mailbox BlockStoreMessage
myMailbox BlockStore
store
blockStoreTx ::
MonadIO m => Peer -> Tx -> BlockStore -> m ()
blockStoreTx :: Peer -> Tx -> BlockStore -> m ()
blockStoreTx Peer
peer Tx
tx BlockStore
store =
Peer -> Tx -> BlockStoreMessage
TxRefReceived Peer
peer Tx
tx BlockStoreMessage -> Mailbox BlockStoreMessage -> m ()
forall (m :: * -> *) (mbox :: * -> *) msg.
(MonadIO m, OutChan mbox) =>
msg -> mbox msg -> m ()
`send` BlockStore -> Mailbox BlockStoreMessage
myMailbox BlockStore
store
blockStoreTxHash ::
MonadIO m => Peer -> [TxHash] -> BlockStore -> m ()
blockStoreTxHash :: Peer -> [TxHash] -> BlockStore -> m ()
blockStoreTxHash Peer
peer [TxHash]
txhashes BlockStore
store =
Peer -> [TxHash] -> BlockStoreMessage
TxRefAvailable Peer
peer [TxHash]
txhashes BlockStoreMessage -> Mailbox BlockStoreMessage -> m ()
forall (m :: * -> *) (mbox :: * -> *) msg.
(MonadIO m, OutChan mbox) =>
msg -> mbox msg -> m ()
`send` BlockStore -> Mailbox BlockStoreMessage
myMailbox BlockStore
store
blockStorePeerConnectSTM ::
Peer -> BlockStore -> STM ()
blockStorePeerConnectSTM :: Peer -> BlockStore -> STM ()
blockStorePeerConnectSTM Peer
peer BlockStore
store =
Peer -> BlockStoreMessage
BlockPeerConnect Peer
peer BlockStoreMessage -> Mailbox BlockStoreMessage -> STM ()
forall (mbox :: * -> *) msg.
OutChan mbox =>
msg -> mbox msg -> STM ()
`sendSTM` BlockStore -> Mailbox BlockStoreMessage
myMailbox BlockStore
store
blockStorePeerDisconnectSTM ::
Peer -> BlockStore -> STM ()
blockStorePeerDisconnectSTM :: Peer -> BlockStore -> STM ()
blockStorePeerDisconnectSTM Peer
peer BlockStore
store =
Peer -> BlockStoreMessage
BlockPeerDisconnect Peer
peer BlockStoreMessage -> Mailbox BlockStoreMessage -> STM ()
forall (mbox :: * -> *) msg.
OutChan mbox =>
msg -> mbox msg -> STM ()
`sendSTM` BlockStore -> Mailbox BlockStoreMessage
myMailbox BlockStore
store
blockStoreHeadSTM ::
BlockNode -> BlockStore -> STM ()
blockStoreHeadSTM :: BlockNode -> BlockStore -> STM ()
blockStoreHeadSTM BlockNode
node BlockStore
store =
BlockNode -> BlockStoreMessage
BlockNewBest BlockNode
node BlockStoreMessage -> Mailbox BlockStoreMessage -> STM ()
forall (mbox :: * -> *) msg.
OutChan mbox =>
msg -> mbox msg -> STM ()
`sendSTM` BlockStore -> Mailbox BlockStoreMessage
myMailbox BlockStore
store
blockStoreBlockSTM ::
Peer -> Block -> BlockStore -> STM ()
blockStoreBlockSTM :: Peer -> Block -> BlockStore -> STM ()
blockStoreBlockSTM Peer
peer Block
block BlockStore
store =
Peer -> Block -> BlockStoreMessage
BlockReceived Peer
peer Block
block BlockStoreMessage -> Mailbox BlockStoreMessage -> STM ()
forall (mbox :: * -> *) msg.
OutChan mbox =>
msg -> mbox msg -> STM ()
`sendSTM` BlockStore -> Mailbox BlockStoreMessage
myMailbox BlockStore
store
blockStoreNotFoundSTM ::
Peer -> [BlockHash] -> BlockStore -> STM ()
blockStoreNotFoundSTM :: Peer -> [BlockHash] -> BlockStore -> STM ()
blockStoreNotFoundSTM Peer
peer [BlockHash]
blocks BlockStore
store =
Peer -> [BlockHash] -> BlockStoreMessage
BlockNotFound Peer
peer [BlockHash]
blocks BlockStoreMessage -> Mailbox BlockStoreMessage -> STM ()
forall (mbox :: * -> *) msg.
OutChan mbox =>
msg -> mbox msg -> STM ()
`sendSTM` BlockStore -> Mailbox BlockStoreMessage
myMailbox BlockStore
store
blockStoreTxSTM ::
Peer -> Tx -> BlockStore -> STM ()
blockStoreTxSTM :: Peer -> Tx -> BlockStore -> STM ()
blockStoreTxSTM Peer
peer Tx
tx BlockStore
store =
Peer -> Tx -> BlockStoreMessage
TxRefReceived Peer
peer Tx
tx BlockStoreMessage -> Mailbox BlockStoreMessage -> STM ()
forall (mbox :: * -> *) msg.
OutChan mbox =>
msg -> mbox msg -> STM ()
`sendSTM` BlockStore -> Mailbox BlockStoreMessage
myMailbox BlockStore
store
blockStoreTxHashSTM ::
Peer -> [TxHash] -> BlockStore -> STM ()
blockStoreTxHashSTM :: Peer -> [TxHash] -> BlockStore -> STM ()
blockStoreTxHashSTM Peer
peer [TxHash]
txhashes BlockStore
store =
Peer -> [TxHash] -> BlockStoreMessage
TxRefAvailable Peer
peer [TxHash]
txhashes BlockStoreMessage -> Mailbox BlockStoreMessage -> STM ()
forall (mbox :: * -> *) msg.
OutChan mbox =>
msg -> mbox msg -> STM ()
`sendSTM` BlockStore -> Mailbox BlockStoreMessage
myMailbox BlockStore
store
blockStorePendingTxs ::
MonadIO m => BlockStore -> m Int
blockStorePendingTxs :: BlockStore -> m Int
blockStorePendingTxs =
STM Int -> m Int
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Int -> m Int)
-> (BlockStore -> STM Int) -> BlockStore -> m Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockStore -> STM Int
blockStorePendingTxsSTM
blockStorePendingTxsSTM ::
BlockStore -> STM Int
blockStorePendingTxsSTM :: BlockStore -> STM Int
blockStorePendingTxsSTM BlockStore {Maybe StoreMetrics
TVar (Maybe Syncing)
TVar (HashMap TxHash PendingTx)
TVar (HashSet TxHash)
Mailbox BlockStoreMessage
BlockStoreConfig
myMetrics :: Maybe StoreMetrics
requested :: TVar (HashSet TxHash)
myTxs :: TVar (HashMap TxHash PendingTx)
myPeer :: TVar (Maybe Syncing)
myConfig :: BlockStoreConfig
myMailbox :: Mailbox BlockStoreMessage
myMetrics :: BlockStore -> Maybe StoreMetrics
requested :: BlockStore -> TVar (HashSet TxHash)
myTxs :: BlockStore -> TVar (HashMap TxHash PendingTx)
myPeer :: BlockStore -> TVar (Maybe Syncing)
myConfig :: BlockStore -> BlockStoreConfig
myMailbox :: BlockStore -> Mailbox BlockStoreMessage
..} = do
HashSet TxHash
x <- HashMap TxHash PendingTx -> HashSet TxHash
forall k a. HashMap k a -> HashSet k
HashMap.keysSet (HashMap TxHash PendingTx -> HashSet TxHash)
-> STM (HashMap TxHash PendingTx) -> STM (HashSet TxHash)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (HashMap TxHash PendingTx) -> STM (HashMap TxHash PendingTx)
forall a. TVar a -> STM a
readTVar TVar (HashMap TxHash PendingTx)
myTxs
HashSet TxHash
y <- TVar (HashSet TxHash) -> STM (HashSet TxHash)
forall a. TVar a -> STM a
readTVar TVar (HashSet TxHash)
requested
Int -> STM Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> STM Int) -> Int -> STM Int
forall a b. (a -> b) -> a -> b
$ HashSet TxHash -> Int
forall a. HashSet a -> Int
HashSet.size (HashSet TxHash -> Int) -> HashSet TxHash -> Int
forall a b. (a -> b) -> a -> b
$ HashSet TxHash
x HashSet TxHash -> HashSet TxHash -> HashSet TxHash
forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
`HashSet.union` HashSet TxHash
y
blockText :: BlockNode -> Maybe Block -> Text
blockText :: BlockNode -> Maybe Block -> Text
blockText BlockNode
bn Maybe Block
mblock = case Maybe Block
mblock of
Maybe Block
Nothing ->
Text
height Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
sep Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
time Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
sep Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
hash
Just Block
block ->
Text
height Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
sep Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
time Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
sep Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
hash Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
sep Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Block -> Text
size Block
block
where
height :: Text
height = String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ BlockHeight -> String
forall a. Show a => a -> String
show (BlockNode -> BlockHeight
nodeHeight BlockNode
bn)
systime :: UTCTime
systime =
NominalDiffTime -> UTCTime
posixSecondsToUTCTime (NominalDiffTime -> UTCTime) -> NominalDiffTime -> UTCTime
forall a b. (a -> b) -> a -> b
$
BlockHeight -> NominalDiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral (BlockHeight -> NominalDiffTime) -> BlockHeight -> NominalDiffTime
forall a b. (a -> b) -> a -> b
$
BlockHeader -> BlockHeight
blockTimestamp (BlockHeader -> BlockHeight) -> BlockHeader -> BlockHeight
forall a b. (a -> b) -> a -> b
$
BlockNode -> BlockHeader
nodeHeader BlockNode
bn
time :: Text
time =
String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$
TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime
TimeLocale
defaultTimeLocale
(Maybe String -> String
iso8601DateFormat (String -> Maybe String
forall a. a -> Maybe a
Just String
"%H:%M"))
UTCTime
systime
hash :: Text
hash = BlockHash -> Text
blockHashToHex (BlockHeader -> BlockHash
headerHash (BlockNode -> BlockHeader
nodeHeader BlockNode
bn))
sep :: Text
sep = Text
" | "
size :: Block -> Text
size = (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" bytes") (Text -> Text) -> (Block -> Text) -> Block -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (String -> Text) -> (Block -> String) -> Block -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> String) -> (Block -> Int) -> Block -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int
B.length (ByteString -> Int) -> (Block -> ByteString) -> Block -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> ByteString
forall a. Serialize a => a -> ByteString
encode