{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE NoFieldSelectors #-}
{-# OPTIONS_GHC -Wno-ambiguous-fields #-}
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 (MaybeT (MaybeT), runMaybeT)
import Data.Bool (bool)
import Data.ByteString qualified as B
import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as HashMap
import Data.HashSet (HashSet)
import Data.HashSet qualified as HashSet
import Data.List (delete)
import Data.Maybe
( catMaybes,
fromJust,
fromMaybe,
isJust,
mapMaybe,
)
import Data.Serialize (encode)
import Data.String (fromString)
import Data.String.Conversions (cs)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Time.Clock
( NominalDiffTime,
UTCTime,
diffUTCTime,
getCurrentTime,
)
import Data.Time.Clock.POSIX
( posixSecondsToUTCTime,
utcTimeToPOSIXSeconds,
)
import Data.Time.Format
( defaultTimeLocale,
formatTime,
)
import Haskoin
( Block (..),
BlockHash (..),
BlockHeader (..),
BlockHeight,
BlockNode (..),
Ctx,
GetData (..),
InvType (..),
InvVector (..),
Message (..),
Network (..),
OutPoint (..),
Tx (..),
TxHash (..),
TxIn (..),
blockHashToHex,
headerHash,
txHash,
txHashToHex,
)
import Haskoin.Node
( Chain,
OnlinePeer (..),
Peer (..),
PeerException (..),
PeerMgr,
chainBlockMain,
chainGetAncestor,
chainGetBest,
chainGetBlock,
chainGetParents,
getPeers,
killPeer,
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 NQE
( InChan,
Listen,
Mailbox,
Publisher,
inboxToMailbox,
newInbox,
publish,
query,
receive,
send,
sendSTM,
)
import System.Metrics.StatsD
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
$cshowsPrec :: Int -> BlockException -> ShowS
showsPrec :: Int -> BlockException -> ShowS
$cshow :: BlockException -> String
show :: BlockException -> String
$cshowList :: [BlockException] -> ShowS
showList :: [BlockException] -> ShowS
Show, BlockException -> BlockException -> Bool
(BlockException -> BlockException -> Bool)
-> (BlockException -> BlockException -> Bool) -> Eq BlockException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BlockException -> BlockException -> Bool
== :: BlockException -> BlockException -> Bool
$c/= :: BlockException -> BlockException -> Bool
/= :: 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
$ccompare :: BlockException -> BlockException -> Ordering
compare :: BlockException -> BlockException -> Ordering
$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
>= :: BlockException -> BlockException -> Bool
$cmax :: BlockException -> BlockException -> BlockException
max :: BlockException -> BlockException -> BlockException
$cmin :: BlockException -> BlockException -> BlockException
min :: BlockException -> BlockException -> 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
$ctoException :: BlockException -> SomeException
toException :: BlockException -> SomeException
$cfromException :: SomeException -> Maybe BlockException
fromException :: SomeException -> Maybe BlockException
$cdisplayException :: BlockException -> String
displayException :: BlockException -> String
Exception)
data Syncing = Syncing
{ Syncing -> Peer
peer :: !Peer,
Syncing -> UTCTime
time :: !UTCTime,
Syncing -> [BlockHash]
blocks :: ![BlockHash]
}
data PendingTx = PendingTx
{ PendingTx -> UTCTime
time :: !UTCTime,
PendingTx -> Tx
tx :: !Tx,
PendingTx -> HashSet TxHash
deps :: !(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
$cshowsPrec :: Int -> PendingTx -> ShowS
showsPrec :: Int -> PendingTx -> ShowS
$cshow :: PendingTx -> String
show :: PendingTx -> String
$cshowList :: [PendingTx] -> ShowS
showList :: [PendingTx] -> ShowS
Show, PendingTx -> PendingTx -> Bool
(PendingTx -> PendingTx -> Bool)
-> (PendingTx -> PendingTx -> Bool) -> Eq PendingTx
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PendingTx -> PendingTx -> Bool
== :: PendingTx -> PendingTx -> Bool
$c/= :: PendingTx -> PendingTx -> Bool
/= :: 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
$ccompare :: PendingTx -> PendingTx -> Ordering
compare :: PendingTx -> PendingTx -> Ordering
$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
>= :: PendingTx -> PendingTx -> Bool
$cmax :: PendingTx -> PendingTx -> PendingTx
max :: PendingTx -> PendingTx -> PendingTx
$cmin :: PendingTx -> PendingTx -> PendingTx
min :: PendingTx -> PendingTx -> PendingTx
Ord)
data BlockStore = BlockStore
{ BlockStore -> Mailbox BlockStoreMessage
mailbox :: !(Mailbox BlockStoreMessage),
BlockStore -> BlockStoreConfig
config :: !BlockStoreConfig,
BlockStore -> TVar (Maybe Syncing)
peer :: !(TVar (Maybe Syncing)),
BlockStore -> TVar (HashMap TxHash PendingTx)
txs :: !(TVar (HashMap TxHash PendingTx)),
BlockStore -> TVar (HashSet TxHash)
requested :: !(TVar (HashSet TxHash)),
BlockStore -> Maybe StoreMetrics
metrics :: !(Maybe StoreMetrics)
}
data StoreMetrics = StoreMetrics
{ StoreMetrics -> StatGauge
blocks :: !StatGauge,
:: !StatGauge,
StoreMetrics -> StatGauge
queuedTxs :: !StatGauge,
StoreMetrics -> StatGauge
peers :: !StatGauge,
StoreMetrics -> StatGauge
mempool :: !StatGauge
}
newStoreMetrics :: (MonadIO m) => BlockStoreConfig -> m (Maybe StoreMetrics)
newStoreMetrics :: forall (m :: * -> *).
MonadIO m =>
BlockStoreConfig -> m (Maybe StoreMetrics)
newStoreMetrics BlockStoreConfig
cfg =
Maybe Stats -> (Stats -> m StoreMetrics) -> m (Maybe StoreMetrics)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM BlockStoreConfig
cfg.stats ((Stats -> m StoreMetrics) -> m (Maybe StoreMetrics))
-> (Stats -> m StoreMetrics) -> m (Maybe StoreMetrics)
forall a b. (a -> b) -> a -> b
$ \Stats
s -> IO StoreMetrics -> m StoreMetrics
forall a. IO a -> m a
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
[(UnixTime, TxHash)]
m <- DatabaseReader
-> DatabaseReaderT IO [(UnixTime, TxHash)]
-> IO [(UnixTime, TxHash)]
forall (m :: * -> *) a.
DatabaseReader -> DatabaseReaderT m a -> m a
withDB BlockStoreConfig
cfg.db DatabaseReaderT IO [(UnixTime, TxHash)]
forall (m :: * -> *). StoreReadBase m => m [(UnixTime, TxHash)]
getMempool
BlockHeight
b <-
(Maybe BlockData -> BlockHeight)
-> IO (Maybe BlockData) -> IO BlockHeight
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (BlockHeight
-> (BlockData -> BlockHeight) -> Maybe BlockData -> BlockHeight
forall b a. b -> (a -> b) -> Maybe a -> b
maybe BlockHeight
0 (.height)) (IO (Maybe BlockData) -> IO BlockHeight)
-> IO (Maybe BlockData) -> IO BlockHeight
forall a b. (a -> b) -> a -> b
$
DatabaseReader
-> DatabaseReaderT IO (Maybe BlockData) -> IO (Maybe BlockData)
forall (m :: * -> *) a.
DatabaseReader -> DatabaseReaderT m a -> m a
withDB BlockStoreConfig
cfg.db (DatabaseReaderT IO (Maybe BlockData) -> IO (Maybe BlockData))
-> DatabaseReaderT IO (Maybe BlockData) -> IO (Maybe BlockData)
forall a b. (a -> b) -> a -> b
$
MaybeT (ReaderT DatabaseReader IO) BlockData
-> DatabaseReaderT IO (Maybe BlockData)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT (ReaderT DatabaseReader IO) BlockData
-> DatabaseReaderT IO (Maybe BlockData))
-> MaybeT (ReaderT DatabaseReader IO) BlockData
-> DatabaseReaderT IO (Maybe BlockData)
forall a b. (a -> b) -> a -> b
$
ReaderT DatabaseReader IO (Maybe BlockHash)
-> MaybeT (ReaderT DatabaseReader IO) BlockHash
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT ReaderT DatabaseReader IO (Maybe BlockHash)
forall (m :: * -> *). StoreReadBase m => m (Maybe BlockHash)
getBestBlock MaybeT (ReaderT DatabaseReader IO) BlockHash
-> (BlockHash -> MaybeT (ReaderT DatabaseReader IO) BlockData)
-> MaybeT (ReaderT DatabaseReader IO) BlockData
forall a b.
MaybeT (ReaderT DatabaseReader IO) a
-> (a -> MaybeT (ReaderT DatabaseReader IO) b)
-> MaybeT (ReaderT DatabaseReader IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= DatabaseReaderT IO (Maybe BlockData)
-> MaybeT (ReaderT DatabaseReader IO) BlockData
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (DatabaseReaderT IO (Maybe BlockData)
-> MaybeT (ReaderT DatabaseReader IO) BlockData)
-> (BlockHash -> DatabaseReaderT IO (Maybe BlockData))
-> BlockHash
-> MaybeT (ReaderT DatabaseReader IO) BlockData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockHash -> DatabaseReaderT IO (Maybe BlockData)
forall (m :: * -> *).
StoreReadBase m =>
BlockHash -> m (Maybe BlockData)
getBlock
BlockNode
h <- Chain -> IO BlockNode
forall (m :: * -> *). MonadIO m => Chain -> m BlockNode
chainGetBest BlockStoreConfig
cfg.chain
[OnlinePeer]
p <- PeerMgr -> IO [OnlinePeer]
forall (m :: * -> *). MonadIO m => PeerMgr -> m [OnlinePeer]
getPeers BlockStoreConfig
cfg.peerMgr
StatGauge
blocks <- Stats -> String -> Int -> IO StatGauge
forall {m :: * -> *}.
MonadIO m =>
Stats -> String -> Int -> m StatGauge
g Stats
s String
"blocks" (BlockHeight -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral BlockHeight
b)
StatGauge
headers <- Stats -> String -> Int -> IO StatGauge
forall {m :: * -> *}.
MonadIO m =>
Stats -> String -> Int -> m StatGauge
g Stats
s String
"headers" (BlockHeight -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral BlockNode
h.height)
StatGauge
queuedTxs <- Stats -> String -> Int -> IO StatGauge
forall {m :: * -> *}.
MonadIO m =>
Stats -> String -> Int -> m StatGauge
g Stats
s String
"queued_txs" Int
0
StatGauge
peers <- Stats -> String -> Int -> IO StatGauge
forall {m :: * -> *}.
MonadIO m =>
Stats -> String -> Int -> m StatGauge
g Stats
s String
"peers" ([OnlinePeer] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [OnlinePeer]
p)
StatGauge
mempool <- Stats -> String -> Int -> IO StatGauge
forall {m :: * -> *}.
MonadIO m =>
Stats -> String -> Int -> m StatGauge
g Stats
s String
"mempool" ([(UnixTime, TxHash)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(UnixTime, TxHash)]
m)
StoreMetrics -> IO StoreMetrics
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return StoreMetrics {StatGauge
$sel:blocks:StoreMetrics :: StatGauge
$sel:headers:StoreMetrics :: StatGauge
$sel:queuedTxs:StoreMetrics :: StatGauge
$sel:peers:StoreMetrics :: StatGauge
$sel:mempool:StoreMetrics :: StatGauge
blocks :: StatGauge
headers :: StatGauge
queuedTxs :: StatGauge
peers :: StatGauge
mempool :: StatGauge
..}
where
g :: Stats -> String -> Int -> m StatGauge
g Stats
s String
x = Stats -> String -> Int -> m StatGauge
forall {m :: * -> *}.
MonadIO m =>
Stats -> String -> Int -> m StatGauge
newStatGauge Stats
s (String
"store." String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
x)
setStoreHeight :: (MonadIO m) => BlockT m ()
setStoreHeight :: forall (m :: * -> *). MonadIO m => BlockT m ()
setStoreHeight = ReaderT BlockStore m (Maybe ()) -> ReaderT BlockStore m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT BlockStore m (Maybe ()) -> ReaderT BlockStore m ())
-> ReaderT BlockStore m (Maybe ()) -> ReaderT BlockStore m ()
forall a b. (a -> b) -> a -> b
$ MaybeT (ReaderT BlockStore m) () -> ReaderT BlockStore m (Maybe ())
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT (ReaderT BlockStore m) ()
-> ReaderT BlockStore m (Maybe ()))
-> MaybeT (ReaderT BlockStore m) ()
-> ReaderT BlockStore m (Maybe ())
forall a b. (a -> b) -> a -> b
$ do
StoreMetrics
m <- ReaderT BlockStore m (Maybe StoreMetrics)
-> MaybeT (ReaderT BlockStore m) StoreMetrics
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT ((BlockStore -> Maybe StoreMetrics)
-> ReaderT BlockStore m (Maybe StoreMetrics)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.metrics))
BlockHash
h <- ReaderT BlockStore m (Maybe BlockHash)
-> MaybeT (ReaderT BlockStore m) BlockHash
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT ReaderT BlockStore m (Maybe BlockHash)
forall (m :: * -> *). StoreReadBase m => m (Maybe BlockHash)
getBestBlock
BlockData
b <- ReaderT BlockStore m (Maybe BlockData)
-> MaybeT (ReaderT BlockStore m) BlockData
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (BlockHash -> ReaderT BlockStore m (Maybe BlockData)
forall (m :: * -> *).
StoreReadBase m =>
BlockHash -> m (Maybe BlockData)
getBlock BlockHash
h)
StatGauge -> Int -> MaybeT (ReaderT BlockStore m) ()
forall (m :: * -> *). MonadIO m => StatGauge -> Int -> m ()
setGauge StoreMetrics
m.blocks (BlockHeight -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral BlockData
b.height)
setHeadersHeight :: (MonadIO m) => BlockT m ()
= ReaderT BlockStore m (Maybe ()) -> ReaderT BlockStore m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT BlockStore m (Maybe ()) -> ReaderT BlockStore m ())
-> ReaderT BlockStore m (Maybe ()) -> ReaderT BlockStore m ()
forall a b. (a -> b) -> a -> b
$ MaybeT (ReaderT BlockStore m) () -> ReaderT BlockStore m (Maybe ())
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT (ReaderT BlockStore m) ()
-> ReaderT BlockStore m (Maybe ()))
-> MaybeT (ReaderT BlockStore m) ()
-> ReaderT BlockStore m (Maybe ())
forall a b. (a -> b) -> a -> b
$ do
StoreMetrics
m <- ReaderT BlockStore m (Maybe StoreMetrics)
-> MaybeT (ReaderT BlockStore m) StoreMetrics
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT ((BlockStore -> Maybe StoreMetrics)
-> ReaderT BlockStore m (Maybe StoreMetrics)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.metrics))
BlockNode
n <- Chain -> MaybeT (ReaderT BlockStore m) BlockNode
forall (m :: * -> *). MonadIO m => Chain -> m BlockNode
chainGetBest (Chain -> MaybeT (ReaderT BlockStore m) BlockNode)
-> MaybeT (ReaderT BlockStore m) Chain
-> MaybeT (ReaderT BlockStore m) BlockNode
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (BlockStore -> Chain) -> MaybeT (ReaderT BlockStore m) Chain
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.config.chain)
StatGauge -> Int -> MaybeT (ReaderT BlockStore m) ()
forall (m :: * -> *). MonadIO m => StatGauge -> Int -> m ()
setGauge StoreMetrics
m.headers (BlockHeight -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral BlockNode
n.height)
setPendingTxs :: (MonadIO m) => BlockT m ()
setPendingTxs :: forall (m :: * -> *). MonadIO m => BlockT m ()
setPendingTxs = ReaderT BlockStore m (Maybe ()) -> ReaderT BlockStore m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT BlockStore m (Maybe ()) -> ReaderT BlockStore m ())
-> ReaderT BlockStore m (Maybe ()) -> ReaderT BlockStore m ()
forall a b. (a -> b) -> a -> b
$ MaybeT (ReaderT BlockStore m) () -> ReaderT BlockStore m (Maybe ())
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT (ReaderT BlockStore m) ()
-> ReaderT BlockStore m (Maybe ()))
-> MaybeT (ReaderT BlockStore m) ()
-> ReaderT BlockStore m (Maybe ())
forall a b. (a -> b) -> a -> b
$ do
StoreMetrics
m <- ReaderT BlockStore m (Maybe StoreMetrics)
-> MaybeT (ReaderT BlockStore m) StoreMetrics
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT ((BlockStore -> Maybe StoreMetrics)
-> ReaderT BlockStore m (Maybe StoreMetrics)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.metrics))
HashMap TxHash PendingTx
p <- TVar (HashMap TxHash PendingTx)
-> MaybeT (ReaderT BlockStore m) (HashMap TxHash PendingTx)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (TVar (HashMap TxHash PendingTx)
-> MaybeT (ReaderT BlockStore m) (HashMap TxHash PendingTx))
-> MaybeT (ReaderT BlockStore m) (TVar (HashMap TxHash PendingTx))
-> MaybeT (ReaderT BlockStore m) (HashMap TxHash PendingTx)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (BlockStore -> TVar (HashMap TxHash PendingTx))
-> MaybeT (ReaderT BlockStore m) (TVar (HashMap TxHash PendingTx))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.txs)
StatGauge -> Int -> MaybeT (ReaderT BlockStore m) ()
forall (m :: * -> *). MonadIO m => StatGauge -> Int -> m ()
setGauge StoreMetrics
m.queuedTxs (HashMap TxHash PendingTx -> Int
forall k v. HashMap k v -> Int
HashMap.size HashMap TxHash PendingTx
p)
setPeersConnected :: (MonadIO m) => BlockT m ()
setPeersConnected :: forall (m :: * -> *). MonadIO m => BlockT m ()
setPeersConnected = ReaderT BlockStore m (Maybe ()) -> ReaderT BlockStore m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT BlockStore m (Maybe ()) -> ReaderT BlockStore m ())
-> ReaderT BlockStore m (Maybe ()) -> ReaderT BlockStore m ()
forall a b. (a -> b) -> a -> b
$ MaybeT (ReaderT BlockStore m) () -> ReaderT BlockStore m (Maybe ())
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT (ReaderT BlockStore m) ()
-> ReaderT BlockStore m (Maybe ()))
-> MaybeT (ReaderT BlockStore m) ()
-> ReaderT BlockStore m (Maybe ())
forall a b. (a -> b) -> a -> b
$ do
StoreMetrics
m <- ReaderT BlockStore m (Maybe StoreMetrics)
-> MaybeT (ReaderT BlockStore m) StoreMetrics
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT ((BlockStore -> Maybe StoreMetrics)
-> ReaderT BlockStore m (Maybe StoreMetrics)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.metrics))
[OnlinePeer]
p <- PeerMgr -> MaybeT (ReaderT BlockStore m) [OnlinePeer]
forall (m :: * -> *). MonadIO m => PeerMgr -> m [OnlinePeer]
getPeers (PeerMgr -> MaybeT (ReaderT BlockStore m) [OnlinePeer])
-> MaybeT (ReaderT BlockStore m) PeerMgr
-> MaybeT (ReaderT BlockStore m) [OnlinePeer]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (BlockStore -> PeerMgr) -> MaybeT (ReaderT BlockStore m) PeerMgr
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.config.peerMgr)
StatGauge -> Int -> MaybeT (ReaderT BlockStore m) ()
forall (m :: * -> *). MonadIO m => StatGauge -> Int -> m ()
setGauge StoreMetrics
m.peers ([OnlinePeer] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [OnlinePeer]
p)
setMempoolSize :: (MonadIO m) => BlockT m ()
setMempoolSize :: forall (m :: * -> *). MonadIO m => BlockT m ()
setMempoolSize = ReaderT BlockStore m (Maybe ()) -> ReaderT BlockStore m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT BlockStore m (Maybe ()) -> ReaderT BlockStore m ())
-> ReaderT BlockStore m (Maybe ()) -> ReaderT BlockStore m ()
forall a b. (a -> b) -> a -> b
$ MaybeT (ReaderT BlockStore m) () -> ReaderT BlockStore m (Maybe ())
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT (ReaderT BlockStore m) ()
-> ReaderT BlockStore m (Maybe ()))
-> MaybeT (ReaderT BlockStore m) ()
-> ReaderT BlockStore m (Maybe ())
forall a b. (a -> b) -> a -> b
$ do
StoreMetrics
m <- ReaderT BlockStore m (Maybe StoreMetrics)
-> MaybeT (ReaderT BlockStore m) StoreMetrics
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT ((BlockStore -> Maybe StoreMetrics)
-> ReaderT BlockStore m (Maybe StoreMetrics)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.metrics))
[(UnixTime, TxHash)]
p <- ReaderT BlockStore m [(UnixTime, TxHash)]
-> MaybeT (ReaderT BlockStore m) [(UnixTime, TxHash)]
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ReaderT BlockStore m [(UnixTime, TxHash)]
forall (m :: * -> *). StoreReadBase m => m [(UnixTime, TxHash)]
getMempool
StatGauge -> Int -> MaybeT (ReaderT BlockStore m) ()
forall (m :: * -> *). MonadIO m => StatGauge -> Int -> m ()
setGauge StoreMetrics
m.mempool ([(UnixTime, TxHash)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(UnixTime, TxHash)]
p)
data BlockStoreConfig = BlockStoreConfig
{ BlockStoreConfig -> Ctx
ctx :: !Ctx,
BlockStoreConfig -> PeerMgr
peerMgr :: !PeerMgr,
BlockStoreConfig -> Chain
chain :: !Chain,
BlockStoreConfig -> Publisher StoreEvent
pub :: !(Publisher StoreEvent),
BlockStoreConfig -> DatabaseReader
db :: !DatabaseReader,
BlockStoreConfig -> Network
net :: !Network,
BlockStoreConfig -> Bool
noMempool :: !Bool,
BlockStoreConfig -> Bool
wipeMempool :: !Bool,
BlockStoreConfig -> Bool
syncMempool :: !Bool,
BlockStoreConfig -> NominalDiffTime
peerTimeout :: !NominalDiffTime,
BlockStoreConfig -> Maybe Stats
stats :: !(Maybe Stats)
}
type BlockT m = ReaderT BlockStore m
runImport ::
(MonadLoggerIO m) =>
Network ->
Ctx ->
WriterT (ExceptT ImportException m) a ->
BlockT m (Either ImportException a)
runImport :: forall (m :: * -> *) a.
MonadLoggerIO m =>
Network
-> Ctx
-> WriterT (ExceptT ImportException m) a
-> BlockT m (Either ImportException a)
runImport Network
net Ctx
ctx WriterT (ExceptT ImportException m) a
f =
(BlockStore -> m (Either ImportException a))
-> ReaderT BlockStore m (Either ImportException a)
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((BlockStore -> m (Either ImportException a))
-> ReaderT BlockStore m (Either ImportException a))
-> (BlockStore -> m (Either ImportException a))
-> ReaderT BlockStore 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
$ Network
-> Ctx
-> DatabaseReader
-> WriterT (ExceptT ImportException m) a
-> ExceptT ImportException m a
forall (m :: * -> *) a.
MonadIO m =>
Network -> Ctx -> DatabaseReader -> WriterT m a -> m a
runWriter Network
net Ctx
ctx BlockStore
r.config.db WriterT (ExceptT ImportException m) a
f
runRocksDB :: ReaderT DatabaseReader m a -> BlockT m a
runRocksDB :: forall (m :: * -> *) a. ReaderT DatabaseReader m a -> BlockT m a
runRocksDB ReaderT DatabaseReader m a
f =
(BlockStore -> m a) -> ReaderT BlockStore m a
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((BlockStore -> m a) -> ReaderT BlockStore m a)
-> (BlockStore -> m a) -> ReaderT BlockStore 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
. (.config.db)
instance (MonadIO m) => StoreReadBase (BlockT m) where
getCtx :: BlockT m Ctx
getCtx =
(BlockStore -> Ctx) -> BlockT m Ctx
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.config.ctx)
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 :: forall (m :: * -> *) a.
(MonadUnliftIO m, MonadLoggerIO m) =>
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 <- BlockStoreConfig -> m (Maybe StoreMetrics)
forall (m :: * -> *).
MonadIO m =>
BlockStoreConfig -> m (Maybe StoreMetrics)
newStoreMetrics BlockStoreConfig
cfg
let r :: BlockStore
r =
BlockStore
{ $sel:mailbox:BlockStore :: Mailbox BlockStoreMessage
mailbox = Inbox BlockStoreMessage -> Mailbox BlockStoreMessage
forall msg. Inbox msg -> Mailbox msg
inboxToMailbox Inbox BlockStoreMessage
inbox,
$sel:config:BlockStore :: BlockStoreConfig
config = BlockStoreConfig
cfg,
$sel:peer:BlockStore :: TVar (Maybe Syncing)
peer = TVar (Maybe Syncing)
pb,
$sel:txs:BlockStore :: TVar (HashMap TxHash PendingTx)
txs = TVar (HashMap TxHash PendingTx)
ts,
$sel:requested:BlockStore :: TVar (HashSet TxHash)
requested = TVar (HashSet TxHash)
rq,
$sel:metrics:BlockStore :: Maybe StoreMetrics
metrics = 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
$(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 a. t a -> 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
Network
net <- ReaderT BlockStore m Network
forall (m :: * -> *). StoreReadBase m => m Network
getNetwork
Ctx
ctx <- ReaderT BlockStore m Ctx
forall (m :: * -> *). StoreReadBase m => m Ctx
getCtx
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 a. [a] -> 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
$
Network
-> Ctx
-> WriterT (ExceptT ImportException m) ()
-> BlockT m (Either ImportException ())
forall (m :: * -> *) a.
MonadLoggerIO m =>
Network
-> Ctx
-> WriterT (ExceptT ImportException m) a
-> BlockT m (Either ImportException a)
runImport Network
net Ctx
ctx ([(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 a b.
ReaderT BlockStore m a
-> (a -> ReaderT BlockStore m b) -> ReaderT BlockStore m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left ImportException
e -> do
$(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
cfg.wipeMempool =
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 a b.
ReaderT BlockStore m a
-> (a -> ReaderT BlockStore m b) -> ReaderT BlockStore m b
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 a. a -> ReaderT BlockStore m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
ini :: ReaderT BlockStore m ()
ini = do
Network
net <- ReaderT BlockStore m Network
forall (m :: * -> *). StoreReadBase m => m Network
getNetwork
Ctx
ctx <- ReaderT BlockStore m Ctx
forall (m :: * -> *). StoreReadBase m => m Ctx
getCtx
Network
-> Ctx
-> WriterT (ExceptT ImportException m) ()
-> BlockT m (Either ImportException ())
forall (m :: * -> *) a.
MonadLoggerIO m =>
Network
-> Ctx
-> WriterT (ExceptT ImportException m) a
-> BlockT m (Either ImportException a)
runImport Network
net Ctx
ctx WriterT (ExceptT ImportException m) ()
forall (m :: * -> *). MonadImport m => m ()
initBest BlockT m (Either ImportException ())
-> (Either ImportException () -> ReaderT BlockStore m ())
-> ReaderT BlockStore m ()
forall a b.
ReaderT BlockStore m a
-> (a -> ReaderT BlockStore m b) -> ReaderT BlockStore m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left ImportException
e -> do
$(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 a. a -> ReaderT BlockStore m a
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
$ \Async ()
a ->
Async () -> ReaderT BlockStore m ()
forall (m :: * -> *) a. MonadIO m => Async a -> m ()
link Async ()
a ReaderT BlockStore m ()
-> ReaderT BlockStore m b -> ReaderT BlockStore m b
forall a b.
ReaderT BlockStore m a
-> ReaderT BlockStore m b -> ReaderT BlockStore m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Inbox BlockStoreMessage -> ReaderT BlockStore m b
forall (mbox :: * -> *) (m :: * -> *) b.
(InChan mbox, MonadUnliftIO m, MonadLoggerIO m) =>
mbox BlockStoreMessage -> ReaderT BlockStore m b
runBlockStoreLoop Inbox BlockStoreMessage
inbox
runBlockStoreLoop ::
(InChan mbox, MonadUnliftIO m, MonadLoggerIO m) =>
mbox BlockStoreMessage ->
ReaderT BlockStore m b
runBlockStoreLoop :: forall (mbox :: * -> *) (m :: * -> *) b.
(InChan mbox, MonadUnliftIO m, MonadLoggerIO m) =>
mbox BlockStoreMessage -> ReaderT BlockStore m b
runBlockStoreLoop mbox BlockStoreMessage
inbox =
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
$ do
$(logDebugS) Text
"BlockStore" Text
"Waiting for new event..."
BlockStoreMessage
msg <- mbox BlockStoreMessage -> ReaderT BlockStore m BlockStoreMessage
forall (mbox :: * -> *) (m :: * -> *) msg.
(InChan mbox, MonadIO m) =>
mbox msg -> m msg
receive mbox BlockStoreMessage
inbox
(BlockStore -> m ()) -> ReaderT BlockStore m ()
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((BlockStore -> m ()) -> ReaderT BlockStore m ())
-> (BlockStore -> m ()) -> ReaderT BlockStore m ()
forall a b. (a -> b) -> a -> b
$ ReaderT BlockStore m () -> BlockStore -> m ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (ReaderT BlockStore m () -> BlockStore -> m ())
-> ReaderT BlockStore m () -> BlockStore -> m ()
forall a b. (a -> b) -> a -> b
$ BlockStoreMessage -> ReaderT BlockStore m ()
forall (m :: * -> *).
(MonadUnliftIO m, MonadLoggerIO m) =>
BlockStoreMessage -> BlockT m ()
processBlockStoreMessage BlockStoreMessage
msg
isInSync :: (MonadLoggerIO m) => BlockT m Bool
isInSync :: forall (m :: * -> *). MonadLoggerIO m => BlockT m Bool
isInSync =
ReaderT BlockStore m (Maybe BlockHash)
forall (m :: * -> *). StoreReadBase m => m (Maybe BlockHash)
getBestBlock ReaderT BlockStore m (Maybe BlockHash)
-> (Maybe BlockHash -> ReaderT BlockStore m Bool)
-> ReaderT BlockStore m Bool
forall a b.
ReaderT BlockStore m a
-> (a -> ReaderT BlockStore m b) -> ReaderT BlockStore m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe BlockHash
Nothing -> do
$(logErrorS) Text
"BlockStore" Text
"Block database uninitialized"
BlockException -> ReaderT BlockStore 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 (.config.chain) ReaderT BlockStore m Chain
-> (Chain -> ReaderT BlockStore m BlockNode)
-> ReaderT BlockStore m BlockNode
forall a b.
ReaderT BlockStore m a
-> (a -> ReaderT BlockStore m b) -> ReaderT BlockStore m b
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
cb.header 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 ()
-> ReaderT BlockStore m Bool -> ReaderT BlockStore m Bool
forall a b.
ReaderT BlockStore m a
-> ReaderT BlockStore m b -> ReaderT BlockStore m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> ReaderT BlockStore m Bool
forall a. a -> ReaderT BlockStore m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
else Bool -> ReaderT BlockStore m Bool
forall a. a -> ReaderT BlockStore m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
guardMempool :: (Monad m) => BlockT m () -> BlockT m ()
guardMempool :: forall (m :: * -> *). Monad m => 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 (.config.noMempool)
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 :: forall (m :: * -> *). Monad m => 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 (.config.syncMempool)
Bool -> BlockT m () -> BlockT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
s BlockT m ()
f
requestMempool :: (MonadUnliftIO m, MonadLoggerIO m) => Peer -> BlockT m ()
requestMempool :: forall (m :: * -> *).
(MonadUnliftIO m, MonadLoggerIO m) =>
Peer -> BlockT m ()
requestMempool 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 a b.
ReaderT BlockStore m a
-> (a -> ReaderT BlockStore m b) -> ReaderT BlockStore m b
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
$(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
p.label
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 :: forall (m :: * -> *).
(MonadUnliftIO m, MonadLoggerIO m) =>
Peer -> Block -> BlockT m ()
processBlock Peer
peer Block
block = ReaderT BlockStore m (Maybe ()) -> ReaderT BlockStore m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT BlockStore m (Maybe ()) -> ReaderT BlockStore m ())
-> (MaybeT (ReaderT BlockStore m) ()
-> ReaderT BlockStore m (Maybe ()))
-> MaybeT (ReaderT BlockStore m) ()
-> ReaderT BlockStore 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) () -> ReaderT BlockStore m ())
-> MaybeT (ReaderT BlockStore m) () -> ReaderT BlockStore 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 a b.
MaybeT (ReaderT BlockStore m) a
-> (a -> MaybeT (ReaderT BlockStore m) b)
-> MaybeT (ReaderT BlockStore m) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
True -> () -> MaybeT (ReaderT BlockStore m) ()
forall a. a -> MaybeT (ReaderT BlockStore m) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Bool
False -> do
$(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
peer.label
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 a. MaybeT (ReaderT BlockStore m) a
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 a b.
MaybeT (ReaderT BlockStore m) a
-> (a -> MaybeT (ReaderT BlockStore m) b)
-> MaybeT (ReaderT BlockStore m) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just BlockNode
b -> BlockNode -> MaybeT (ReaderT BlockStore m) BlockNode
forall a. a -> MaybeT (ReaderT BlockStore m) a
forall (m :: * -> *) a. Monad m => a -> m a
return BlockNode
b
Maybe BlockNode
Nothing -> do
$(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
peer.label
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 a. MaybeT (ReaderT BlockStore m) a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
$(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
peer.label
Network
net <- ReaderT BlockStore m Network
-> MaybeT (ReaderT BlockStore m) Network
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ReaderT BlockStore m Network
forall (m :: * -> *). StoreReadBase m => m Network
getNetwork
Ctx
ctx <- ReaderT BlockStore m Ctx -> MaybeT (ReaderT BlockStore m) Ctx
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ReaderT BlockStore m Ctx
forall (m :: * -> *). StoreReadBase m => m Ctx
getCtx
ReaderT BlockStore m () -> MaybeT (ReaderT BlockStore m) ()
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT BlockStore m () -> MaybeT (ReaderT BlockStore m) ())
-> (ReaderT BlockStore m () -> ReaderT BlockStore m ())
-> ReaderT BlockStore m ()
-> MaybeT (ReaderT BlockStore m) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Block -> ReaderT BlockStore m () -> ReaderT BlockStore 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) (ReaderT BlockStore m () -> MaybeT (ReaderT BlockStore m) ())
-> ReaderT BlockStore m () -> MaybeT (ReaderT BlockStore m) ()
forall a b. (a -> b) -> a -> b
$
Network
-> Ctx
-> WriterT (ExceptT ImportException m) (BlockData, [TxData])
-> BlockT m (Either ImportException (BlockData, [TxData]))
forall (m :: * -> *) a.
MonadLoggerIO m =>
Network
-> Ctx
-> WriterT (ExceptT ImportException m) a
-> BlockT m (Either ImportException a)
runImport Network
net Ctx
ctx (Block
-> BlockNode
-> WriterT (ExceptT ImportException m) (BlockData, [TxData])
forall (m :: * -> *).
MonadImport m =>
Block -> BlockNode -> m (BlockData, [TxData])
importBlock Block
block BlockNode
node) BlockT m (Either ImportException (BlockData, [TxData]))
-> (Either ImportException (BlockData, [TxData])
-> ReaderT BlockStore m ())
-> ReaderT BlockStore m ()
forall a b.
ReaderT BlockStore m a
-> (a -> ReaderT BlockStore m b) -> ReaderT BlockStore m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left ImportException
e -> ImportException -> ReaderT BlockStore m ()
forall {m :: * -> *} {a}.
(MonadLogger m, Show a, MonadIO m) =>
a -> m ()
failure ImportException
e
Right (BlockData, [TxData])
_ -> BlockNode -> ReaderT BlockStore m ()
forall {m :: * -> *}.
(MonadLoggerIO m, MonadUnliftIO m) =>
BlockNode -> ReaderT BlockStore m ()
success BlockNode
node
where
header :: BlockHeader
header = Block
block.header
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
$(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 BlockNode
node.header
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 a b.
ReaderT BlockStore m a
-> (a -> ReaderT BlockStore m b) -> ReaderT BlockStore m b
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 ()
requestMempool Peer
peer
failure :: a -> m ()
failure a
e = do
$(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
peer.label
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 :: forall (m :: * -> *).
(MonadReader BlockStore m, MonadIO m) =>
[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 (.peer) m (TVar (Maybe Syncing)) -> (TVar (Maybe Syncing) -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \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 :: Syncing) {blocks = hs}
getSyncingBlocks :: (MonadReader BlockStore m, MonadIO m) => m [BlockHash]
getSyncingBlocks :: forall (m :: * -> *).
(MonadReader BlockStore m, MonadIO m) =>
m [BlockHash]
getSyncingBlocks =
(BlockStore -> TVar (Maybe Syncing)) -> m (TVar (Maybe Syncing))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.peer) m (TVar (Maybe Syncing))
-> (TVar (Maybe Syncing) -> m (Maybe Syncing)) -> m (Maybe Syncing)
forall a b. m a -> (a -> m b) -> m b
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 a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe Syncing
Nothing -> [BlockHash] -> m [BlockHash]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
Just Syncing
x -> [BlockHash] -> m [BlockHash]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Syncing
x.blocks
addSyncingBlocks ::
(MonadReader BlockStore m, MonadIO m) =>
[BlockHash] ->
m ()
addSyncingBlocks :: forall (m :: * -> *).
(MonadReader BlockStore m, MonadIO m) =>
[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 (.peer) m (TVar (Maybe Syncing)) -> (TVar (Maybe Syncing) -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \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 :: Syncing) {blocks = x.blocks <> hs}
removeSyncingBlock ::
(MonadReader BlockStore m, MonadIO m) =>
BlockHash ->
m ()
removeSyncingBlock :: forall (m :: * -> *).
(MonadReader BlockStore m, MonadIO m) =>
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 (.peer)
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 :: Syncing) {blocks = delete h x.blocks}
checkPeer :: (MonadLoggerIO m, MonadReader BlockStore m) => Peer -> m Bool
checkPeer :: forall (m :: * -> *).
(MonadLoggerIO m, MonadReader BlockStore m) =>
Peer -> m Bool
checkPeer Peer
p = (Maybe Bool -> Bool) -> m (Maybe Bool) -> m Bool
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False) (m (Maybe Bool) -> m Bool)
-> (MaybeT m Bool -> m (Maybe Bool)) -> MaybeT m Bool -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MaybeT m Bool -> m (Maybe Bool)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT m Bool -> m Bool) -> MaybeT m Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ do
Syncing {Peer
$sel:peer:Syncing :: Syncing -> Peer
peer :: Peer
peer} <- m (Maybe Syncing) -> MaybeT m Syncing
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT m (Maybe Syncing)
forall (m :: * -> *).
(MonadIO m, MonadReader BlockStore m) =>
m (Maybe Syncing)
getSyncingState
Bool -> MaybeT m Bool
forall a. a -> MaybeT m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> MaybeT m Bool) -> Bool -> MaybeT m Bool
forall a b. (a -> b) -> a -> b
$ Peer
peer Peer -> Peer -> Bool
forall a. Eq a => a -> a -> Bool
== Peer
p
getBlockNode ::
(MonadLoggerIO m, MonadReader BlockStore m) =>
BlockHash ->
m (Maybe BlockNode)
getBlockNode :: forall (m :: * -> *).
(MonadLoggerIO m, MonadReader BlockStore m) =>
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 (.config.chain)
processNoBlocks ::
(MonadLoggerIO m) =>
Peer ->
[BlockHash] ->
BlockT m ()
processNoBlocks :: forall (m :: * -> *).
MonadLoggerIO m =>
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) ->
$(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 a. [a] -> 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
p.label
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 :: forall (m :: * -> *). MonadLoggerIO m => 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 a. IO a -> ReaderT BlockStore m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
$(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
p.label
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 :: forall (m :: * -> *). MonadIO m => 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 (.txs)
UTCTime
now <- IO UTCTime -> ReaderT BlockStore m UTCTime
forall a. IO a -> ReaderT BlockStore m a
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
p.time NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
> NominalDiffTime
600
addPendingTx :: (MonadIO m) => PendingTx -> BlockT m ()
addPendingTx :: forall (m :: * -> *). MonadIO m => 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 (.txs)
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 (.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
$ 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
BlockT m ()
forall (m :: * -> *). MonadIO m => BlockT m ()
setPendingTxs
where
th :: TxHash
th = Tx -> TxHash
txHash PendingTx
p.tx
addRequestedTx :: (MonadIO m) => TxHash -> BlockT m ()
addRequestedTx :: forall (m :: * -> *). MonadIO m => 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 (.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 a. IO a -> ReaderT BlockStore m a
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 :: forall (m :: * -> *). MonadIO m => 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 (.txs)
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 (.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 a. a -> STM a
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 :: forall (m :: * -> *). MonadIO m => 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 (.txs) ReaderT BlockStore m (TVar (HashMap TxHash PendingTx))
-> (TVar (HashMap TxHash PendingTx) -> BlockT m [PendingTx])
-> BlockT m [PendingTx]
forall a b.
ReaderT BlockStore m a
-> (a -> ReaderT BlockStore m b) -> ReaderT BlockStore m b
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)
forall {t :: * -> *} {v} {a}.
(Foldable t, HasField "tx" v Tx, HasField "deps" v (t a), Eq v) =>
HashMap TxHash v -> ([v], HashMap TxHash v)
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 a. a -> STM a
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 a. a -> ReaderT BlockStore m a
forall (m :: * -> *) a. Monad m => a -> m a
return [PendingTx]
selected
where
select :: HashMap TxHash v -> ([v], HashMap TxHash v)
select HashMap TxHash v
pend =
let eligible :: HashMap TxHash v
eligible = (v -> Bool) -> HashMap TxHash v -> HashMap TxHash v
forall v k. (v -> Bool) -> HashMap k v -> HashMap k v
HashMap.filter (t a -> Bool
forall a. t a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (t a -> Bool) -> (v -> t a) -> v -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.deps)) HashMap TxHash v
pend
orphans :: HashMap TxHash v
orphans = HashMap TxHash v -> HashMap TxHash v -> HashMap TxHash v
forall k v w.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k w -> HashMap k v
HashMap.difference HashMap TxHash v
pend HashMap TxHash v
eligible
selected :: [v]
selected = Int -> [v] -> [v]
forall a. Int -> [a] -> [a]
take Int
i ([v] -> [v]) -> [v] -> [v]
forall a b. (a -> b) -> a -> b
$ HashMap TxHash v -> [v]
forall {b}. HasField "tx" b Tx => HashMap TxHash b -> [b]
sortit HashMap TxHash v
eligible
remaining :: HashMap TxHash v
remaining = (v -> Bool) -> HashMap TxHash v -> HashMap TxHash v
forall v k. (v -> Bool) -> HashMap k v -> HashMap k v
HashMap.filter (v -> [v] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [v]
selected) HashMap TxHash v
eligible
in ([v]
selected, HashMap TxHash v
remaining HashMap TxHash v -> HashMap TxHash v -> HashMap TxHash v
forall a. Semigroup a => a -> a -> a
<> HashMap TxHash v
orphans)
sortit :: HashMap TxHash b -> [b]
sortit HashMap TxHash b
m =
let sorted :: [(BlockHeight, Tx)]
sorted = [Tx] -> [(BlockHeight, Tx)]
sortTxs ([Tx] -> [(BlockHeight, Tx)]) -> [Tx] -> [(BlockHeight, Tx)]
forall a b. (a -> b) -> a -> b
$ (b -> Tx) -> [b] -> [Tx]
forall a b. (a -> b) -> [a] -> [b]
map (.tx) ([b] -> [Tx]) -> [b] -> [Tx]
forall a b. (a -> b) -> a -> b
$ HashMap TxHash b -> [b]
forall k v. HashMap k v -> [v]
HashMap.elems HashMap TxHash b
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 b) -> [TxHash] -> [b]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (TxHash -> HashMap TxHash b -> Maybe b
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
`HashMap.lookup` HashMap TxHash b
m) [TxHash]
txids
fulfillOrphans :: (MonadIO m) => BlockStore -> TxHash -> m ()
fulfillOrphans :: forall (m :: * -> *). MonadIO m => 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
block_read.txs
fulfill :: PendingTx -> PendingTx
fulfill PendingTx
p = PendingTx
p {deps = HashSet.delete th p.deps}
updateOrphans ::
( StoreReadBase m,
MonadLoggerIO m,
MonadReader BlockStore m
) =>
m ()
updateOrphans :: forall (m :: * -> *).
(StoreReadBase m, MonadLoggerIO m, MonadReader BlockStore m) =>
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 (.txs)
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 a. HashSet a -> 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
. (.deps)) 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
p.tx
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 a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
True -> Maybe PendingTx -> m (Maybe PendingTx)
forall a. a -> m a
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 a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe TxData
Nothing -> Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
Just TxData {$sel:deleted:TxData :: TxData -> Bool
deleted = Bool
True} -> Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
Just TxData {$sel:deleted:TxData :: TxData -> Bool
deleted = Bool
False} -> Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
prev_utxos :: r -> f [Unspent]
prev_utxos r
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
<$> (a -> f (Maybe Unspent)) -> [a] -> f [Maybe Unspent]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (OutPoint -> f (Maybe Unspent)
forall (m :: * -> *).
StoreReadBase m =>
OutPoint -> m (Maybe Unspent)
getUnspent (OutPoint -> f (Maybe Unspent))
-> (a -> OutPoint) -> a -> f (Maybe Unspent)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.outpoint)) r
tx.inputs
fulfill :: PendingTx -> p -> PendingTx
fulfill PendingTx
p p
unspent =
let unspent_hash :: TxHash
unspent_hash = p
unspent.outpoint.hash
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
p.deps
in PendingTx
p {deps = new_deps}
fill_deps :: PendingTx -> m PendingTx
fill_deps PendingTx
p = do
let tx :: Tx
tx = PendingTx
p.tx
[Unspent]
unspents <- Tx -> m [Unspent]
forall {f :: * -> *} {a} {r}.
(StoreReadBase f, HasField "outpoint" a OutPoint,
HasField "inputs" r [a]) =>
r -> f [Unspent]
prev_utxos Tx
tx
PendingTx -> m PendingTx
forall a. a -> m a
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 b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl PendingTx -> Unspent -> PendingTx
forall {r} {p}.
(HasField "hash" r TxHash, HasField "outpoint" p r) =>
PendingTx -> p -> PendingTx
fulfill PendingTx
p [Unspent]
unspents
newOrphanTx ::
(MonadLoggerIO m) =>
BlockStore ->
UTCTime ->
Tx ->
WriterT m ()
newOrphanTx :: forall (m :: * -> *).
MonadLoggerIO m =>
BlockStore -> UTCTime -> Tx -> WriterT m ()
newOrphanTx BlockStore
block_read UTCTime
time Tx
tx = do
$(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
block_read.txs
[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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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 (.outpoint) [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 (.hash) 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
{ $sel:time:PendingTx :: UTCTime
time = UTCTime
time,
$sel:tx:PendingTx :: Tx
tx = Tx
tx,
$sel:deps:PendingTx :: HashSet TxHash
deps = 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 (.outpoint) Tx
tx.inputs
importMempoolTx ::
(MonadLoggerIO m, MonadError ImportException m) =>
BlockStore ->
UTCTime ->
Tx ->
WriterT m Bool
importMempoolTx :: forall (m :: * -> *).
(MonadLoggerIO m, MonadError ImportException m) =>
BlockStore -> UTCTime -> Tx -> WriterT m Bool
importMempoolTx BlockStore
block_read UTCTime
time Tx
tx =
ReaderT Writer m Bool
-> (ImportException -> ReaderT Writer m Bool)
-> ReaderT Writer m Bool
forall a.
ReaderT Writer m a
-> (ImportException -> ReaderT Writer m a) -> ReaderT Writer m a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError ReaderT Writer m Bool
new_mempool_tx ImportException -> ReaderT Writer 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 a. a -> ReaderT Writer m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
handle_error ImportException
_ = Bool -> ReaderT Writer m Bool
forall a. a -> ReaderT Writer m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
seconds :: UnixTime
seconds = NominalDiffTime -> UnixTime
forall b. Integral b => NominalDiffTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (UTCTime -> NominalDiffTime
utcTimeToPOSIXSeconds UTCTime
time)
new_mempool_tx :: ReaderT Writer m Bool
new_mempool_tx = do
Bool
t <- Tx -> UnixTime -> ReaderT Writer m Bool
forall (m :: * -> *). MonadImport m => Tx -> UnixTime -> m Bool
newMempoolTx Tx
tx UnixTime
seconds
$(logInfoS) Text
"BlockStore" (Text -> ReaderT Writer m ()) -> Text -> ReaderT Writer m ()
forall a b. (a -> b) -> a -> b
$
Text -> Text -> Bool -> Text
forall a. a -> a -> Bool -> a
bool Text
"Already have" Text
"Imported" Bool
t
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" tx "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TxHash -> Text
txHashToHex (Tx -> TxHash
txHash Tx
tx)
Bool -> ReaderT Writer m () -> ReaderT Writer m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
t (ReaderT Writer m () -> ReaderT Writer m ())
-> ReaderT Writer m () -> ReaderT Writer m ()
forall a b. (a -> b) -> a -> b
$ BlockStore -> TxHash -> ReaderT Writer m ()
forall (m :: * -> *). MonadIO m => BlockStore -> TxHash -> m ()
fulfillOrphans BlockStore
block_read TxHash
tx_hash
Bool -> ReaderT Writer m Bool
forall a. a -> ReaderT Writer m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
t
notify :: (MonadIO m) => Maybe Block -> BlockT m a -> BlockT m a
notify :: forall (m :: * -> *) a.
MonadIO m =>
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 => 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 => 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 (.config.pub)
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
b.header)) Publisher StoreEvent
l
Maybe Block
Nothing -> () -> ReaderT BlockStore m ()
forall a. a -> ReaderT BlockStore m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
a -> BlockT m a
forall a. a -> ReaderT BlockStore 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
b.txs)
Maybe Block
Nothing -> HashSet TxHash
forall a. HashSet a
HashSet.empty
processMempool :: (MonadLoggerIO m) => BlockT m ()
processMempool :: forall (m :: * -> *). MonadLoggerIO m => 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 a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PendingTx]
txs) (BlockStore -> [PendingTx] -> BlockT m ()
forall {t :: * -> *} {m :: * -> *} {a}.
(Traversable t, MonadLoggerIO m, HasField "time" a UTCTime,
HasField "tx" a Tx) =>
BlockStore -> t a -> ReaderT BlockStore m ()
import_txs BlockStore
block_read [PendingTx]
txs)
where
run_import :: BlockStore -> r -> WriterT m Bool
run_import BlockStore
block_read r
p =
BlockStore -> UTCTime -> Tx -> WriterT m Bool
forall (m :: * -> *).
(MonadLoggerIO m, MonadError ImportException m) =>
BlockStore -> UTCTime -> Tx -> WriterT m Bool
importMempoolTx BlockStore
block_read r
p.time r
p.tx
import_txs :: BlockStore -> t a -> ReaderT BlockStore m ()
import_txs BlockStore
block_read t a
txs =
let r :: ReaderT Writer (ExceptT ImportException m) (t Bool)
r = (a -> ReaderT Writer (ExceptT ImportException m) Bool)
-> t a -> ReaderT Writer (ExceptT ImportException m) (t Bool)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> t a -> m (t b)
mapM (BlockStore -> a -> ReaderT Writer (ExceptT ImportException m) Bool
forall {m :: * -> *} {r}.
(MonadLoggerIO m, MonadError ImportException m,
HasField "time" r UTCTime, HasField "tx" r Tx) =>
BlockStore -> r -> WriterT m Bool
run_import BlockStore
block_read) t a
txs
in do
Network
net <- ReaderT BlockStore m Network
forall (m :: * -> *). StoreReadBase m => m Network
getNetwork
Ctx
ctx <- ReaderT BlockStore m Ctx
forall (m :: * -> *). StoreReadBase m => m Ctx
getCtx
Network
-> Ctx
-> ReaderT Writer (ExceptT ImportException m) (t Bool)
-> BlockT m (Either ImportException (t Bool))
forall (m :: * -> *) a.
MonadLoggerIO m =>
Network
-> Ctx
-> WriterT (ExceptT ImportException m) a
-> BlockT m (Either ImportException a)
runImport Network
net Ctx
ctx 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 a b.
ReaderT BlockStore m a
-> (a -> ReaderT BlockStore m b) -> ReaderT BlockStore m b
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 a. a -> ReaderT BlockStore m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
report_error :: e -> m b
report_error e
e = do
$(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 :: forall (m :: * -> *).
MonadLoggerIO m =>
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
$(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 a. [a] -> 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
p.label
[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 a. [a] -> 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 a. [a] -> 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 a b.
ReaderT BlockStore m a
-> (a -> ReaderT BlockStore m b) -> ReaderT BlockStore m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
True -> do
$(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 a. a -> ReaderT BlockStore m a
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 a b.
ReaderT BlockStore m a
-> (a -> ReaderT BlockStore m b) -> ReaderT BlockStore m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just TxData
_ -> do
$(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 a. a -> ReaderT BlockStore m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe TxHash
forall a. Maybe a
Nothing
Maybe TxData
Nothing -> do
$(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 a. a -> ReaderT BlockStore m a
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 (.config.net)
let inv :: InvType
inv = if Network
net.segWit 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
. (.get)) [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 :: forall (m :: * -> *). (MonadIO m, MonadReader BlockStore m) => m ()
touchPeer =
m (Maybe Syncing)
forall (m :: * -> *).
(MonadIO m, MonadReader BlockStore m) =>
m (Maybe Syncing)
getSyncingState m (Maybe Syncing) -> (Maybe Syncing -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe Syncing
Nothing -> () -> m ()
forall a. a -> m a
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 (.peer)
UTCTime
now <- IO UTCTime -> m UTCTime
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
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 a b. (a -> b) -> Maybe a -> Maybe b
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 :: Syncing) {time = now}
checkTime :: (MonadLoggerIO m) => BlockT m ()
checkTime :: forall (m :: * -> *). MonadLoggerIO m => 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 (.peer) ReaderT BlockStore m (TVar (Maybe Syncing))
-> (TVar (Maybe Syncing) -> ReaderT BlockStore m (Maybe Syncing))
-> ReaderT BlockStore m (Maybe Syncing)
forall a b.
ReaderT BlockStore m a
-> (a -> ReaderT BlockStore m b) -> ReaderT BlockStore m b
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 -> ReaderT BlockStore m ())
-> ReaderT BlockStore m ()
forall a b.
ReaderT BlockStore m a
-> (a -> ReaderT BlockStore m b) -> ReaderT BlockStore m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe Syncing
Nothing -> () -> ReaderT BlockStore m ()
forall a. a -> ReaderT BlockStore m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just
Syncing
{ $sel:time:Syncing :: Syncing -> UTCTime
time = UTCTime
t,
$sel:peer:Syncing :: Syncing -> Peer
peer = Peer
p
} -> do
UTCTime
now <- IO UTCTime -> ReaderT BlockStore m UTCTime
forall a. IO a -> ReaderT BlockStore m a
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 (.config.peerTimeout)
Bool -> ReaderT BlockStore m () -> ReaderT BlockStore 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) (ReaderT BlockStore m () -> ReaderT BlockStore m ())
-> ReaderT BlockStore m () -> ReaderT BlockStore m ()
forall a b. (a -> b) -> a -> b
$ do
$(logErrorS) Text
"BlockStore" (Text -> ReaderT BlockStore m ())
-> Text -> ReaderT BlockStore m ()
forall a b. (a -> b) -> a -> b
$
Text
"Syncing peer timeout: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer
p.label
PeerException -> Peer -> ReaderT BlockStore m ()
forall (m :: * -> *). MonadIO m => PeerException -> Peer -> m ()
killPeer PeerException
PeerTimeout Peer
p
revertToMainChain :: (MonadLoggerIO m) => BlockT m ()
revertToMainChain :: forall (m :: * -> *). MonadLoggerIO m => 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
. (.header) (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 (.config.chain)
Network
net <- ReaderT BlockStore m Network
forall (m :: * -> *). StoreReadBase m => m Network
getNetwork
Ctx
ctx <- ReaderT BlockStore m Ctx
forall (m :: * -> *). StoreReadBase m => m Ctx
getCtx
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 a b.
ReaderT BlockStore m a
-> (a -> ReaderT BlockStore m b) -> ReaderT BlockStore m b
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
$(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
Network
-> Ctx
-> WriterT (ExceptT ImportException m) ()
-> BlockT m (Either ImportException ())
forall (m :: * -> *) a.
MonadLoggerIO m =>
Network
-> Ctx
-> WriterT (ExceptT ImportException m) a
-> BlockT m (Either ImportException a)
runImport Network
net Ctx
ctx (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 a b.
ReaderT BlockStore m a
-> (a -> ReaderT BlockStore m b) -> ReaderT BlockStore m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left ImportException
e -> do
$(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 :: forall (m :: * -> *). MonadLoggerIO m => 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 a b.
ReaderT BlockStore m a
-> (a -> ReaderT BlockStore m b) -> ReaderT BlockStore m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just BlockHash
b -> BlockHash -> ReaderT BlockStore m BlockHash
forall a. a -> ReaderT BlockStore m a
forall (m :: * -> *) a. Monad m => a -> m a
return BlockHash
b
Maybe BlockHash
Nothing -> do
$(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 (.config.chain)
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 a b.
ReaderT BlockStore m a
-> (a -> ReaderT BlockStore m b) -> ReaderT BlockStore m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just BlockNode
x -> BlockNode -> BlockT m BlockNode
forall a. a -> ReaderT BlockStore m a
forall (m :: * -> *) a. Monad m => a -> m a
return BlockNode
x
Maybe BlockNode
Nothing -> do
$(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 :: forall (m :: * -> *). MonadLoggerIO m => 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 a b.
ReaderT BlockStore m a
-> (a -> ReaderT BlockStore m b) -> ReaderT BlockStore m b
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 a b.
ReaderT BlockStore m a
-> (a -> ReaderT BlockStore m b) -> ReaderT BlockStore m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just BlockHash
b -> BlockHash -> ReaderT BlockStore m BlockHash
forall a. a -> ReaderT BlockStore m a
forall (m :: * -> *) a. Monad m => a -> m a
return BlockHash
b
Maybe BlockHash
Nothing -> do
$(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 a. a -> ReaderT BlockStore m a
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. HasCallStack => [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 (.config.chain)
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 a b.
ReaderT BlockStore m a
-> (a -> ReaderT BlockStore m b) -> ReaderT BlockStore m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just BlockNode
x -> BlockNode -> BlockT m BlockNode
forall a. a -> ReaderT BlockStore m a
forall (m :: * -> *) a. Monad m => a -> m a
return BlockNode
x
Maybe BlockNode
Nothing -> do
$(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 :: forall (m :: * -> *). MonadLoggerIO m => BlockT m (Maybe Peer)
shouldSync =
BlockT m Bool
forall (m :: * -> *). MonadLoggerIO m => BlockT m Bool
isInSync BlockT m Bool
-> (Bool -> ReaderT BlockStore m (Maybe Peer))
-> ReaderT BlockStore m (Maybe Peer)
forall a b.
ReaderT BlockStore m a
-> (a -> ReaderT BlockStore m b) -> ReaderT BlockStore m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
True -> Maybe Peer -> ReaderT BlockStore m (Maybe Peer)
forall a. a -> ReaderT BlockStore m a
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 -> ReaderT BlockStore m (Maybe Peer))
-> ReaderT BlockStore m (Maybe Peer)
forall a b.
ReaderT BlockStore m a
-> (a -> ReaderT BlockStore m b) -> ReaderT BlockStore m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe Syncing
Nothing -> Maybe Peer -> ReaderT BlockStore m (Maybe Peer)
forall a. a -> ReaderT BlockStore m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Peer
forall a. Maybe a
Nothing
Just Syncing {$sel:peer:Syncing :: Syncing -> Peer
peer = Peer
p, $sel:blocks:Syncing :: Syncing -> [BlockHash]
blocks = [BlockHash]
bs}
| Int
100 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> [BlockHash] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BlockHash]
bs -> Maybe Peer -> ReaderT BlockStore m (Maybe Peer)
forall a. a -> ReaderT BlockStore m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Peer -> Maybe Peer
forall a. a -> Maybe a
Just Peer
p)
| Bool
otherwise -> Maybe Peer -> ReaderT BlockStore m (Maybe Peer)
forall a. a -> ReaderT BlockStore m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Peer
forall a. Maybe a
Nothing
syncMe :: (MonadLoggerIO m) => BlockT m ()
syncMe :: forall (m :: * -> *). MonadLoggerIO m => 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 a b.
ReaderT BlockStore m a
-> (a -> ReaderT BlockStore m b) -> ReaderT BlockStore m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe Peer
Nothing -> () -> BlockT m ()
forall a. a -> ReaderT BlockStore m a
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 :: * -> *} {r}.
(MonadLoggerIO m, MonadReader BlockStore m,
HasField "height" r BlockHeight) =>
r -> BlockNode -> m [BlockNode]
sel BlockNode
bb BlockNode
bh
[InvVector]
iv <- [BlockNode] -> ReaderT BlockStore m [InvVector]
forall {m :: * -> *} {r} {a} {b} {b}.
(MonadReader r m, HasField "header" a BlockHeader,
HasField "net" b b, HasField "segWit" b Bool,
HasField "config" r b) =>
[a] -> m [InvVector]
getiv [BlockNode]
bns
$(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 a. [a] -> 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
p.label
[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
. (.header)) [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 :: [a] -> m [InvVector]
getiv [a]
bns = do
Bool
w <- (r -> Bool) -> m Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.config.net.segWit)
let i :: InvType
i = if Bool
w then InvType
InvWitnessBlock else InvType
InvBlock
f :: a -> InvVector
f = InvType -> Hash256 -> InvVector
InvVector InvType
i (Hash256 -> InvVector) -> (a -> Hash256) -> a -> InvVector
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.get) (BlockHash -> Hash256) -> (a -> BlockHash) -> a -> Hash256
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockHeader -> BlockHash
headerHash (BlockHeader -> BlockHash) -> (a -> BlockHeader) -> a -> BlockHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.header)
[InvVector] -> m [InvVector]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([InvVector] -> m [InvVector]) -> [InvVector] -> m [InvVector]
forall a b. (a -> b) -> a -> b
$ (a -> InvVector) -> [a] -> [InvVector]
forall a b. (a -> b) -> [a] -> [b]
map a -> InvVector
f [a]
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 (.config.chain)
sel :: r -> BlockNode -> m [BlockNode]
sel r
bb BlockNode
bh = do
let sh :: BlockHeight
sh = r -> BlockNode -> BlockHeight
forall {a} {r} {r}.
(Ord a, Num a, HasField "height" r a, HasField "height" r a) =>
r -> r -> a
geth r
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 (.config.chain)
[BlockNode]
ps <- BlockHeight -> BlockNode -> Chain -> m [BlockNode]
forall (m :: * -> *).
MonadIO m =>
BlockHeight -> BlockNode -> Chain -> m [BlockNode]
chainGetParents (r
bb.height BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
+ BlockHeight
1) BlockNode
t Chain
ch
[BlockNode] -> m [BlockNode]
forall a. a -> m a
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 a. [a] -> 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 :: r -> r -> a
geth r
bb r
bh =
a -> a -> a
forall a. Ord a => a -> a -> a
min (r
bb.height a -> a -> a
forall a. Num a => a -> a -> a
+ a
501) r
bh.height
top :: BlockHeight -> BlockNode -> m BlockNode
top BlockHeight
sh BlockNode
bh =
if BlockHeight
sh BlockHeight -> BlockHeight -> Bool
forall a. Eq a => a -> a -> Bool
== BlockNode
bh.height
then BlockNode -> m BlockNode
forall a. a -> m a
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 :: forall {m :: * -> *}.
(MonadLoggerIO m, MonadReader BlockStore m) =>
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 (.config.chain)
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 a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just BlockNode
ancestor -> BlockNode -> m BlockNode
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return BlockNode
ancestor
Maybe BlockNode
Nothing -> do
let h :: BlockHash
h = BlockHeader -> BlockHash
headerHash BlockNode
target.header
$(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
target.height)
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 :: forall (m :: * -> *).
(MonadLoggerIO m, MonadReader BlockStore m) =>
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 (.peer)
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 a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just Syncing {$sel:peer:Syncing :: Syncing -> Peer
peer = 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 a. a -> m a
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
$(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
p.label
Peer -> m ()
forall (m :: * -> *). MonadIO m => Peer -> m ()
setFree Peer
p
trySetPeer :: (MonadLoggerIO m) => Peer -> BlockT m Bool
trySetPeer :: forall (m :: * -> *). MonadLoggerIO m => 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 -> ReaderT BlockStore m Bool)
-> ReaderT BlockStore m Bool
forall a b.
ReaderT BlockStore m a
-> (a -> ReaderT BlockStore m b) -> ReaderT BlockStore m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just Syncing
_ -> Bool -> ReaderT BlockStore m Bool
forall a. a -> ReaderT BlockStore m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
Maybe Syncing
Nothing -> ReaderT BlockStore m Bool
set_it
where
set_it :: ReaderT BlockStore m Bool
set_it =
Peer -> ReaderT BlockStore m Bool
forall (m :: * -> *). MonadIO m => Peer -> m Bool
setBusy Peer
p ReaderT BlockStore m Bool
-> (Bool -> ReaderT BlockStore m Bool) -> ReaderT BlockStore m Bool
forall a b.
ReaderT BlockStore m a
-> (a -> ReaderT BlockStore m b) -> ReaderT BlockStore m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
False -> Bool -> ReaderT BlockStore m Bool
forall a. a -> ReaderT BlockStore m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
Bool
True -> do
$(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
p.label
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 (.peer)
UTCTime
now <- IO UTCTime -> ReaderT BlockStore m UTCTime
forall a. IO a -> ReaderT BlockStore m a
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
{ $sel:peer:Syncing :: Peer
peer = Peer
p,
$sel:time:Syncing :: UTCTime
time = UTCTime
now,
$sel:blocks:Syncing :: [BlockHash]
blocks = []
}
Bool -> ReaderT BlockStore m Bool
forall a. a -> ReaderT BlockStore m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
trySyncing :: (MonadLoggerIO m) => BlockT m ()
trySyncing :: forall (m :: * -> *). MonadLoggerIO m => BlockT m ()
trySyncing =
BlockT m Bool
forall (m :: * -> *). MonadLoggerIO m => BlockT m Bool
isInSync BlockT m Bool
-> (Bool -> ReaderT BlockStore m ()) -> ReaderT BlockStore m ()
forall a b.
ReaderT BlockStore m a
-> (a -> ReaderT BlockStore m b) -> ReaderT BlockStore m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
True -> () -> ReaderT BlockStore m ()
forall a. a -> ReaderT BlockStore m a
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 -> ReaderT BlockStore m ())
-> ReaderT BlockStore m ()
forall a b.
ReaderT BlockStore m a
-> (a -> ReaderT BlockStore m b) -> ReaderT BlockStore m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just Syncing
_ -> () -> ReaderT BlockStore m ()
forall a. a -> ReaderT BlockStore m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Maybe Syncing
Nothing -> ReaderT BlockStore m ()
online_peer
where
recurse :: [Peer] -> ReaderT BlockStore m ()
recurse [] = () -> ReaderT BlockStore m ()
forall a. a -> ReaderT BlockStore m a
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 a b.
ReaderT BlockStore m a
-> (a -> ReaderT BlockStore m b) -> ReaderT BlockStore m b
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 :: ReaderT BlockStore m ()
online_peer = do
[OnlinePeer]
ops <- PeerMgr -> ReaderT BlockStore m [OnlinePeer]
forall (m :: * -> *). MonadIO m => PeerMgr -> m [OnlinePeer]
getPeers (PeerMgr -> ReaderT BlockStore m [OnlinePeer])
-> ReaderT BlockStore m PeerMgr
-> ReaderT BlockStore m [OnlinePeer]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (BlockStore -> PeerMgr) -> ReaderT BlockStore m PeerMgr
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.config.peerMgr)
let ps :: [Peer]
ps = (OnlinePeer -> Peer) -> [OnlinePeer] -> [Peer]
forall a b. (a -> b) -> [a] -> [b]
map (.mailbox) [OnlinePeer]
ops
[Peer] -> ReaderT BlockStore m ()
forall {m :: * -> *}.
MonadLoggerIO m =>
[Peer] -> ReaderT BlockStore m ()
recurse [Peer]
ps
trySyncingPeer :: (MonadUnliftIO m, MonadLoggerIO m) => Peer -> BlockT m ()
trySyncingPeer :: forall (m :: * -> *).
(MonadUnliftIO m, MonadLoggerIO m) =>
Peer -> BlockT m ()
trySyncingPeer Peer
p =
BlockT m Bool
forall (m :: * -> *). MonadLoggerIO m => BlockT m Bool
isInSync BlockT m Bool
-> (Bool -> ReaderT BlockStore m ()) -> ReaderT BlockStore m ()
forall a b.
ReaderT BlockStore m a
-> (a -> ReaderT BlockStore m b) -> ReaderT BlockStore m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
True -> Peer -> ReaderT BlockStore m ()
forall (m :: * -> *).
(MonadUnliftIO m, MonadLoggerIO m) =>
Peer -> BlockT m ()
requestMempool Peer
p
Bool
False ->
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 a b.
ReaderT BlockStore m a
-> (a -> ReaderT BlockStore m b) -> ReaderT BlockStore m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
False -> () -> ReaderT BlockStore m ()
forall a. a -> ReaderT BlockStore m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Bool
True -> ReaderT BlockStore m ()
forall (m :: * -> *). MonadLoggerIO m => BlockT m ()
syncMe
getSyncingState ::
(MonadIO m, MonadReader BlockStore m) => m (Maybe Syncing)
getSyncingState :: forall (m :: * -> *).
(MonadIO m, MonadReader BlockStore m) =>
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 (.peer)
clearSyncingState ::
(MonadLoggerIO m, MonadReader BlockStore m) => m ()
clearSyncingState :: forall (m :: * -> *).
(MonadLoggerIO m, MonadReader BlockStore m) =>
m ()
clearSyncingState =
(BlockStore -> TVar (Maybe Syncing)) -> m (TVar (Maybe Syncing))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.peer) m (TVar (Maybe Syncing))
-> (TVar (Maybe Syncing) -> m (Maybe Syncing)) -> m (Maybe Syncing)
forall a b. m a -> (a -> m b) -> m b
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 a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe Syncing
Nothing -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Syncing {$sel:peer:Syncing :: Syncing -> Peer
peer = 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 :: forall (m :: * -> *).
(MonadUnliftIO m, MonadLoggerIO m) =>
BlockStoreMessage -> BlockT m ()
processBlockStoreMessage (BlockNewBest BlockNode
node) = do
$(logDebugS) Text
"BlockStore" (Text -> BlockT m ()) -> Text -> BlockT m ()
forall a b. (a -> b) -> a -> b
$
Text
"New best block mined 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
node.height)
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> BlockHash -> Text
blockHashToHex (BlockHeader -> BlockHash
headerHash BlockNode
node.header)
BlockT m ()
forall (m :: * -> *). MonadLoggerIO m => BlockT m ()
trySyncing
processBlockStoreMessage (BlockPeerConnect Peer
p) = do
$(logDebugS) Text
"BlockStore" (Text -> BlockT m ()) -> Text -> BlockT m ()
forall a b. (a -> b) -> a -> b
$
Text
"New peer connected: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer
p.label
Peer -> BlockT m ()
forall (m :: * -> *).
(MonadUnliftIO m, MonadLoggerIO m) =>
Peer -> BlockT m ()
trySyncingPeer Peer
p
processBlockStoreMessage (BlockPeerDisconnect Peer
p) = do
$(logDebugS) Text
"BlockStore" (Text -> BlockT m ()) -> Text -> BlockT m ()
forall a b. (a -> b) -> a -> b
$
Text
"Peer disconnected: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer
p.label
Peer -> BlockT m ()
forall (m :: * -> *).
(MonadLoggerIO m, MonadReader BlockStore m) =>
Peer -> m ()
finishPeer Peer
p
processBlockStoreMessage (BlockReceived Peer
p Block
b) = do
$(logDebugS) Text
"BlockStore" (Text -> BlockT m ()) -> Text -> BlockT m ()
forall a b. (a -> b) -> a -> b
$
Text
"Received block: "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> BlockHash -> Text
blockHashToHex (BlockHeader -> BlockHash
headerHash Block
b.header)
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) = do
$(logDebugS) Text
"BlockStore" (Text -> BlockT m ()) -> Text -> BlockT m ()
forall a b. (a -> b) -> a -> b
$
Text
"Blocks not found by peer "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer
p.label
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.unwords ((BlockHash -> Text) -> [BlockHash] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map BlockHash -> Text
blockHashToHex [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) = do
$(logDebugS) Text
"BlockStore" (Text -> BlockT m ()) -> Text -> BlockT m ()
forall a b. (a -> b) -> a -> b
$
Text
"Transaction received from peer "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer
p.label
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TxHash -> Text
txHashToHex (Tx -> TxHash
txHash 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) = do
$(logDebugS) Text
"BlockStore" (Text -> BlockT m ()) -> Text -> BlockT m ()
forall a b. (a -> b) -> a -> b
$
Text
"Transactions available from peer "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer
p.label
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.unwords ((TxHash -> Text) -> [TxHash] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map TxHash -> Text
txHashToHex [TxHash]
ts)
Peer -> [TxHash] -> BlockT m ()
forall (m :: * -> *).
MonadLoggerIO m =>
Peer -> [TxHash] -> BlockT m ()
processTxs Peer
p [TxHash]
ts
processBlockStoreMessage (BlockPing Listen ()
r) = do
$(logDebugS) Text
"BlockStore" Text
"Internal clock event"
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 :: forall (m :: * -> *).
MonadLoggerIO m =>
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 a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> m Int) -> IO Int -> m Int
forall a b. (a -> b) -> a -> b
$
CharPos -> IO Int
forall a (m :: * -> *). (Random a, MonadIO m) => (a, a) -> m a
randomRIO
( Int
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 :: forall (m :: * -> *). MonadIO m => 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
store.mailbox
blockStorePeerDisconnect ::
(MonadIO m) => Peer -> BlockStore -> m ()
blockStorePeerDisconnect :: forall (m :: * -> *). MonadIO m => 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
store.mailbox
blockStoreHead ::
(MonadIO m) => BlockNode -> BlockStore -> m ()
blockStoreHead :: forall (m :: * -> *). MonadIO m => 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
store.mailbox
blockStoreBlock ::
(MonadIO m) => Peer -> Block -> BlockStore -> m ()
blockStoreBlock :: forall (m :: * -> *).
MonadIO m =>
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
store.mailbox
blockStoreNotFound ::
(MonadIO m) => Peer -> [BlockHash] -> BlockStore -> m ()
blockStoreNotFound :: forall (m :: * -> *).
MonadIO m =>
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
store.mailbox
blockStoreTx ::
(MonadIO m) => Peer -> Tx -> BlockStore -> m ()
blockStoreTx :: forall (m :: * -> *). MonadIO m => 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
store.mailbox
blockStoreTxHash ::
(MonadIO m) => Peer -> [TxHash] -> BlockStore -> m ()
blockStoreTxHash :: forall (m :: * -> *).
MonadIO m =>
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
store.mailbox
blockStorePeerConnectSTM ::
Peer -> BlockStore -> STM ()
blockStorePeerConnectSTM :: Peer -> BlockStore -> STM ()
blockStorePeerConnectSTM Peer
peer BlockStore
store =
Peer -> BlockStoreMessage
BlockPeerConnect Peer
peer BlockStoreMessage -> Mailbox BlockStoreMessage -> STM ()
forall msg. msg -> Mailbox msg -> STM ()
forall (mbox :: * -> *) msg.
OutChan mbox =>
msg -> mbox msg -> STM ()
`sendSTM` BlockStore
store.mailbox
blockStorePeerDisconnectSTM ::
Peer -> BlockStore -> STM ()
blockStorePeerDisconnectSTM :: Peer -> BlockStore -> STM ()
blockStorePeerDisconnectSTM Peer
peer BlockStore
store =
Peer -> BlockStoreMessage
BlockPeerDisconnect Peer
peer BlockStoreMessage -> Mailbox BlockStoreMessage -> STM ()
forall msg. msg -> Mailbox msg -> STM ()
forall (mbox :: * -> *) msg.
OutChan mbox =>
msg -> mbox msg -> STM ()
`sendSTM` BlockStore
store.mailbox
blockStoreHeadSTM ::
BlockNode -> BlockStore -> STM ()
blockStoreHeadSTM :: BlockNode -> BlockStore -> STM ()
blockStoreHeadSTM BlockNode
node BlockStore
store =
BlockNode -> BlockStoreMessage
BlockNewBest BlockNode
node BlockStoreMessage -> Mailbox BlockStoreMessage -> STM ()
forall msg. msg -> Mailbox msg -> STM ()
forall (mbox :: * -> *) msg.
OutChan mbox =>
msg -> mbox msg -> STM ()
`sendSTM` BlockStore
store.mailbox
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 msg. msg -> Mailbox msg -> STM ()
forall (mbox :: * -> *) msg.
OutChan mbox =>
msg -> mbox msg -> STM ()
`sendSTM` BlockStore
store.mailbox
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 msg. msg -> Mailbox msg -> STM ()
forall (mbox :: * -> *) msg.
OutChan mbox =>
msg -> mbox msg -> STM ()
`sendSTM` BlockStore
store.mailbox
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 msg. msg -> Mailbox msg -> STM ()
forall (mbox :: * -> *) msg.
OutChan mbox =>
msg -> mbox msg -> STM ()
`sendSTM` BlockStore
store.mailbox
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 msg. msg -> Mailbox msg -> STM ()
forall (mbox :: * -> *) msg.
OutChan mbox =>
msg -> mbox msg -> STM ()
`sendSTM` BlockStore
store.mailbox
blockStorePendingTxs ::
(MonadIO m) => BlockStore -> m Int
blockStorePendingTxs :: forall (m :: * -> *). MonadIO m => 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
$sel:mailbox:BlockStore :: BlockStore -> Mailbox BlockStoreMessage
$sel:config:BlockStore :: BlockStore -> BlockStoreConfig
$sel:peer:BlockStore :: BlockStore -> TVar (Maybe Syncing)
$sel:txs:BlockStore :: BlockStore -> TVar (HashMap TxHash PendingTx)
$sel:requested:BlockStore :: BlockStore -> TVar (HashSet TxHash)
$sel:metrics:BlockStore :: BlockStore -> Maybe StoreMetrics
mailbox :: Mailbox BlockStoreMessage
config :: BlockStoreConfig
peer :: TVar (Maybe Syncing)
txs :: TVar (HashMap TxHash PendingTx)
requested :: TVar (HashSet TxHash)
metrics :: Maybe StoreMetrics
..} = 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)
txs
HashSet TxHash
y <- TVar (HashSet TxHash) -> STM (HashSet TxHash)
forall a. TVar a -> STM a
readTVar TVar (HashSet TxHash)
requested
Int -> STM Int
forall a. a -> STM a
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 => 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
t 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
t 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
bn.height
b :: UTCTime
b = 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 BlockNode
bn.header.timestamp
t :: Text
t = 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 String
"%FT%T" UTCTime
b
hash :: Text
hash = BlockHash -> Text
blockHashToHex (BlockHeader -> BlockHash
headerHash BlockNode
bn.header)
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