{-# 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
  ( -- * Block Store
    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)

-- | Block store process state.
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,
    StoreMetrics -> StatGauge
headers :: !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 ()
setHeadersHeight :: forall (m :: * -> *). MonadIO m => BlockT m ()
setHeadersHeight = 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)

-- | Configuration for a block store.
data BlockStoreConfig = BlockStoreConfig
  { BlockStoreConfig -> Ctx
ctx :: !Ctx,
    -- | peer manager from running node
    BlockStoreConfig -> PeerMgr
peerMgr :: !PeerMgr,
    -- | chain from a running node
    BlockStoreConfig -> Chain
chain :: !Chain,
    -- | listener for store events
    BlockStoreConfig -> Publisher StoreEvent
pub :: !(Publisher StoreEvent),
    -- | RocksDB database handle
    BlockStoreConfig -> DatabaseReader
db :: !DatabaseReader,
    -- | network constants
    BlockStoreConfig -> Network
net :: !Network,
    -- | do not index new mempool transactions
    BlockStoreConfig -> Bool
noMempool :: !Bool,
    -- | wipe mempool at start
    BlockStoreConfig -> Bool
wipeMempool :: !Bool,
    -- | sync mempool from peers
    BlockStoreConfig -> Bool
syncMempool :: !Bool,
    -- | disconnect syncing peer if inactive for this long
    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

-- | Run block store process.
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, Hashable a) => HashSet a -> HashSet a -> HashSet a
HashSet.union HashSet TxHash
e (HashSet TxHash -> HashSet TxHash)
-> ([(UnixTime, TxHash)] -> HashSet TxHash)
-> [(UnixTime, TxHash)]
-> HashSet TxHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TxHash] -> HashSet TxHash
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HashSet.fromList ([TxHash] -> HashSet TxHash)
-> ([(UnixTime, TxHash)] -> [TxHash])
-> [(UnixTime, TxHash)]
-> HashSet TxHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((UnixTime, TxHash) -> TxHash) -> [(UnixTime, TxHash)] -> [TxHash]
forall a b. (a -> b) -> [a] -> [b]
map (UnixTime, TxHash) -> TxHash
forall a b. (a, b) -> b
snd ([(UnixTime, TxHash)] -> HashSet TxHash)
-> ReaderT BlockStore m [(UnixTime, TxHash)]
-> ReaderT BlockStore m (HashSet TxHash)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT BlockStore m [(UnixTime, TxHash)]
forall (m :: * -> *). StoreReadBase m => m [(UnixTime, TxHash)]
getMempool
  a
x <- BlockT m a
go
  HashSet TxHash
new <- HashSet TxHash -> HashSet TxHash -> HashSet TxHash
forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
HashSet.union HashSet TxHash
e (HashSet TxHash -> HashSet TxHash)
-> ([(UnixTime, TxHash)] -> HashSet TxHash)
-> [(UnixTime, TxHash)]
-> HashSet TxHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TxHash] -> HashSet TxHash
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HashSet.fromList ([TxHash] -> HashSet TxHash)
-> ([(UnixTime, TxHash)] -> [TxHash])
-> [(UnixTime, TxHash)]
-> HashSet TxHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((UnixTime, TxHash) -> TxHash) -> [(UnixTime, TxHash)] -> [TxHash]
forall a b. (a -> b) -> [a] -> [b]
map (UnixTime, TxHash) -> TxHash
forall a b. (a, b) -> b
snd ([(UnixTime, TxHash)] -> HashSet TxHash)
-> ReaderT BlockStore m [(UnixTime, TxHash)]
-> ReaderT BlockStore m (HashSet TxHash)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT BlockStore m [(UnixTime, TxHash)]
forall (m :: * -> *). StoreReadBase m => m [(UnixTime, TxHash)]
getMempool
  Publisher StoreEvent
l <- (BlockStore -> Publisher StoreEvent)
-> ReaderT BlockStore m (Publisher StoreEvent)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.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, Hashable a) => HashSet a -> HashSet a -> HashSet a
`HashSet.union` HashSet TxHash
y

blockText :: BlockNode -> Maybe Block -> Text
blockText :: BlockNode -> Maybe Block -> Text
blockText BlockNode
bn Maybe Block
mblock = case Maybe Block
mblock of
  Maybe Block
Nothing ->
    Text
height Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
sep Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
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