{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ImportQualifiedPost #-}

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 (runMaybeT)
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,
    isJust,
    mapMaybe,
  )
import Data.Serialize (encode)
import Data.String (fromString)
import Data.String.Conversions (cs)
import Data.Text (Text)
import Data.Time.Clock
  ( NominalDiffTime,
    UTCTime,
    diffUTCTime,
    getCurrentTime,
  )
import Data.Time.Clock.POSIX
  ( posixSecondsToUTCTime,
    utcTimeToPOSIXSeconds,
  )
import Data.Time.Format
  ( defaultTimeLocale,
    formatTime,
  )
import Haskoin
  ( Block (..),
    BlockHash (..),
    BlockHeader (..),
    BlockHeight,
    BlockNode (..),
    GetData (..),
    InvType (..),
    InvVector (..),
    Message (..),
    Network (..),
    OutPoint (..),
    Tx (..),
    TxHash (..),
    TxIn (..),
    blockHashToHex,
    headerHash,
    txHash,
    txHashToHex,
  )
import Haskoin.Node
  ( Chain,
    OnlinePeer (..),
    Peer,
    PeerException (..),
    PeerManager,
    chainBlockMain,
    chainGetAncestor,
    chainGetBest,
    chainGetBlock,
    chainGetParents,
    getPeers,
    killPeer,
    peerText,
    sendMessage,
    setBusy,
    setFree,
  )
import Haskoin.Store.Common
import Haskoin.Store.Data
import Haskoin.Store.Database.Reader
import Haskoin.Store.Database.Writer
import Haskoin.Store.Logic
  ( ImportException (Orphan),
    deleteUnconfirmedTx,
    importBlock,
    initBest,
    newMempoolTx,
    revertBlock,
  )
import Haskoin.Store.Stats
import NQE
  ( Listen,
    Mailbox,
    Publisher,
    inboxToMailbox,
    newInbox,
    publish,
    query,
    receive,
    send,
    sendSTM,
  )
import System.Metrics qualified as Metrics
import System.Metrics.Gauge qualified as Metrics (Gauge)
import System.Metrics.Gauge qualified as Metrics.Gauge
import System.Random (randomRIO)
import UnliftIO
  ( Exception,
    MonadIO,
    MonadUnliftIO,
    STM,
    TVar,
    async,
    atomically,
    liftIO,
    link,
    modifyTVar,
    newTVarIO,
    readTVar,
    readTVarIO,
    throwIO,
    withAsync,
    writeTVar,
  )
import UnliftIO.Concurrent (threadDelay)

data BlockStoreMessage
  = BlockNewBest !BlockNode
  | BlockPeerConnect !Peer
  | BlockPeerDisconnect !Peer
  | BlockReceived !Peer !Block
  | BlockNotFound !Peer ![BlockHash]
  | TxRefReceived !Peer !Tx
  | TxRefAvailable !Peer ![TxHash]
  | BlockPing !(Listen ())

data BlockException
  = BlockNotInChain !BlockHash
  | Uninitialized
  | CorruptDatabase
  | AncestorNotInChain !BlockHeight !BlockHash
  | MempoolImportFailed
  deriving (Int -> BlockException -> ShowS
[BlockException] -> ShowS
BlockException -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BlockException] -> ShowS
$cshowList :: [BlockException] -> ShowS
show :: BlockException -> String
$cshow :: BlockException -> String
showsPrec :: Int -> BlockException -> ShowS
$cshowsPrec :: Int -> BlockException -> ShowS
Show, BlockException -> BlockException -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BlockException -> BlockException -> Bool
$c/= :: BlockException -> BlockException -> Bool
== :: BlockException -> BlockException -> Bool
$c== :: BlockException -> BlockException -> Bool
Eq, Eq BlockException
BlockException -> BlockException -> Bool
BlockException -> BlockException -> Ordering
BlockException -> BlockException -> BlockException
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: BlockException -> BlockException -> BlockException
$cmin :: BlockException -> BlockException -> BlockException
max :: BlockException -> BlockException -> BlockException
$cmax :: BlockException -> BlockException -> BlockException
>= :: BlockException -> BlockException -> Bool
$c>= :: BlockException -> BlockException -> Bool
> :: BlockException -> BlockException -> Bool
$c> :: BlockException -> BlockException -> Bool
<= :: BlockException -> BlockException -> Bool
$c<= :: BlockException -> BlockException -> Bool
< :: BlockException -> BlockException -> Bool
$c< :: BlockException -> BlockException -> Bool
compare :: BlockException -> BlockException -> Ordering
$ccompare :: BlockException -> BlockException -> Ordering
Ord, Show BlockException
Typeable BlockException
SomeException -> Maybe BlockException
BlockException -> String
BlockException -> SomeException
forall e.
Typeable e
-> Show e
-> (e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> Exception e
displayException :: BlockException -> String
$cdisplayException :: BlockException -> String
fromException :: SomeException -> Maybe BlockException
$cfromException :: SomeException -> Maybe BlockException
toException :: BlockException -> SomeException
$ctoException :: BlockException -> SomeException
Exception)

data Syncing = Syncing
  { Syncing -> Peer
syncingPeer :: !Peer,
    Syncing -> UTCTime
syncingTime :: !UTCTime,
    Syncing -> [BlockHash]
syncingBlocks :: ![BlockHash]
  }

data PendingTx = PendingTx
  { PendingTx -> UTCTime
pendingTxTime :: !UTCTime,
    PendingTx -> Tx
pendingTx :: !Tx,
    PendingTx -> HashSet TxHash
pendingDeps :: !(HashSet TxHash)
  }
  deriving (Int -> PendingTx -> ShowS
[PendingTx] -> ShowS
PendingTx -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PendingTx] -> ShowS
$cshowList :: [PendingTx] -> ShowS
show :: PendingTx -> String
$cshow :: PendingTx -> String
showsPrec :: Int -> PendingTx -> ShowS
$cshowsPrec :: Int -> PendingTx -> ShowS
Show, PendingTx -> PendingTx -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PendingTx -> PendingTx -> Bool
$c/= :: PendingTx -> PendingTx -> Bool
== :: PendingTx -> PendingTx -> Bool
$c== :: PendingTx -> PendingTx -> Bool
Eq, Eq PendingTx
PendingTx -> PendingTx -> Bool
PendingTx -> PendingTx -> Ordering
PendingTx -> PendingTx -> PendingTx
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: PendingTx -> PendingTx -> PendingTx
$cmin :: PendingTx -> PendingTx -> PendingTx
max :: PendingTx -> PendingTx -> PendingTx
$cmax :: PendingTx -> PendingTx -> PendingTx
>= :: PendingTx -> PendingTx -> Bool
$c>= :: PendingTx -> PendingTx -> Bool
> :: PendingTx -> PendingTx -> Bool
$c> :: PendingTx -> PendingTx -> Bool
<= :: PendingTx -> PendingTx -> Bool
$c<= :: PendingTx -> PendingTx -> Bool
< :: PendingTx -> PendingTx -> Bool
$c< :: PendingTx -> PendingTx -> Bool
compare :: PendingTx -> PendingTx -> Ordering
$ccompare :: PendingTx -> PendingTx -> Ordering
Ord)

-- | Block store process state.
data BlockStore = BlockStore
  { BlockStore -> Mailbox BlockStoreMessage
myMailbox :: !(Mailbox BlockStoreMessage),
    BlockStore -> BlockStoreConfig
myConfig :: !BlockStoreConfig,
    BlockStore -> TVar (Maybe Syncing)
myPeer :: !(TVar (Maybe Syncing)),
    BlockStore -> TVar (HashMap TxHash PendingTx)
myTxs :: !(TVar (HashMap TxHash PendingTx)),
    BlockStore -> TVar (HashSet TxHash)
requested :: !(TVar (HashSet TxHash)),
    BlockStore -> Maybe StoreMetrics
myMetrics :: !(Maybe StoreMetrics)
  }

data StoreMetrics = StoreMetrics
  { StoreMetrics -> Gauge
storeHeight :: !Metrics.Gauge,
    StoreMetrics -> Gauge
headersHeight :: !Metrics.Gauge,
    StoreMetrics -> Gauge
storePendingTxs :: !Metrics.Gauge,
    StoreMetrics -> Gauge
storePeersConnected :: !Metrics.Gauge,
    StoreMetrics -> Gauge
storeMempoolSize :: !Metrics.Gauge
  }

newStoreMetrics :: MonadIO m => Metrics.Store -> m StoreMetrics
newStoreMetrics :: forall (m :: * -> *). MonadIO m => Store -> m StoreMetrics
newStoreMetrics Store
s = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
  Gauge
storeHeight <- Text -> IO Gauge
g Text
"blockchain.height"
  Gauge
headersHeight <- Text -> IO Gauge
g Text
"blockchain.headers"
  Gauge
storePendingTxs <- Text -> IO Gauge
g Text
"mempool.pending_txs"
  Gauge
storePeersConnected <- Text -> IO Gauge
g Text
"network.peers_connected"
  Gauge
storeMempoolSize <- Text -> IO Gauge
g Text
"mempool.size"
  forall (m :: * -> *) a. Monad m => a -> m a
return StoreMetrics {Gauge
storeMempoolSize :: Gauge
storePeersConnected :: Gauge
storePendingTxs :: Gauge
headersHeight :: Gauge
storeHeight :: Gauge
storeMempoolSize :: Gauge
storePeersConnected :: Gauge
storePendingTxs :: Gauge
headersHeight :: Gauge
storeHeight :: Gauge
..}
  where
    g :: Text -> IO Gauge
g Text
x = Text -> Store -> IO Gauge
Metrics.createGauge (Text
"store." forall a. Semigroup a => a -> a -> a
<> Text
x) Store
s

setStoreHeight :: MonadIO m => BlockT m ()
setStoreHeight :: forall (m :: * -> *). MonadIO m => BlockT m ()
setStoreHeight =
  forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> Maybe StoreMetrics
myMetrics forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe StoreMetrics
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just StoreMetrics
m ->
      forall (m :: * -> *). StoreReadBase m => m (Maybe BlockHash)
getBestBlock forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe BlockHash
Nothing -> forall {m :: * -> *} {a}.
(MonadIO m, Integral a) =>
StoreMetrics -> a -> m ()
setit StoreMetrics
m Integer
0
        Just BlockHash
bb ->
          forall (m :: * -> *).
StoreReadBase m =>
BlockHash -> m (Maybe BlockData)
getBlock BlockHash
bb forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Maybe BlockData
Nothing -> forall {m :: * -> *} {a}.
(MonadIO m, Integral a) =>
StoreMetrics -> a -> m ()
setit StoreMetrics
m Integer
0
            Just BlockData
b -> forall {m :: * -> *} {a}.
(MonadIO m, Integral a) =>
StoreMetrics -> a -> m ()
setit StoreMetrics
m (BlockData -> BlockHeight
blockDataHeight BlockData
b)
  where
    setit :: StoreMetrics -> a -> m ()
setit StoreMetrics
m a
i = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ StoreMetrics -> Gauge
storeHeight StoreMetrics
m Gauge -> Int64 -> IO ()
`Metrics.Gauge.set` forall a b. (Integral a, Num b) => a -> b
fromIntegral a
i

setHeadersHeight :: MonadIO m => BlockT m ()
setHeadersHeight :: forall (m :: * -> *). MonadIO m => BlockT m ()
setHeadersHeight =
  forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> Maybe StoreMetrics
myMetrics forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe StoreMetrics
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just StoreMetrics
m -> do
      BlockHeight
h <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BlockNode -> BlockHeight
nodeHeight forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => Chain -> m BlockNode
chainGetBest forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (BlockStoreConfig -> Chain
blockConfChain forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockStore -> BlockStoreConfig
myConfig)
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ StoreMetrics -> Gauge
headersHeight StoreMetrics
m Gauge -> Int64 -> IO ()
`Metrics.Gauge.set` forall a b. (Integral a, Num b) => a -> b
fromIntegral BlockHeight
h

setPendingTxs :: MonadIO m => BlockT m ()
setPendingTxs :: forall (m :: * -> *). MonadIO m => BlockT m ()
setPendingTxs =
  forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> Maybe StoreMetrics
myMetrics forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe StoreMetrics
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just StoreMetrics
m -> do
      Int
s <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> TVar (HashMap TxHash PendingTx)
myTxs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \TVar (HashMap TxHash PendingTx)
t -> forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (forall k v. HashMap k v -> Int
HashMap.size forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TVar a -> STM a
readTVar TVar (HashMap TxHash PendingTx)
t)
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ StoreMetrics -> Gauge
storePendingTxs StoreMetrics
m Gauge -> Int64 -> IO ()
`Metrics.Gauge.set` forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
s

setPeersConnected :: MonadIO m => BlockT m ()
setPeersConnected :: forall (m :: * -> *). MonadIO m => BlockT m ()
setPeersConnected =
  forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> Maybe StoreMetrics
myMetrics forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe StoreMetrics
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just StoreMetrics
m -> do
      Int
ps <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => PeerManager -> m [OnlinePeer]
getPeers forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (BlockStoreConfig -> PeerManager
blockConfManager forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockStore -> BlockStoreConfig
myConfig)
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ StoreMetrics -> Gauge
storePeersConnected StoreMetrics
m Gauge -> Int64 -> IO ()
`Metrics.Gauge.set` forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ps

setMempoolSize :: MonadIO m => BlockT m ()
setMempoolSize :: forall (m :: * -> *). MonadIO m => BlockT m ()
setMempoolSize =
  forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> Maybe StoreMetrics
myMetrics forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe StoreMetrics
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just StoreMetrics
m -> do
      Int
s <- forall (t :: * -> *) a. Foldable t => t a -> Int
length forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). StoreReadBase m => m [(UnixTime, TxHash)]
getMempool
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ StoreMetrics -> Gauge
storeMempoolSize StoreMetrics
m Gauge -> Int64 -> IO ()
`Metrics.Gauge.set` forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
s

-- | Configuration for a block store.
data BlockStoreConfig = BlockStoreConfig
  { -- | peer manager from running node
    BlockStoreConfig -> PeerManager
blockConfManager :: !PeerManager,
    -- | chain from a running node
    BlockStoreConfig -> Chain
blockConfChain :: !Chain,
    -- | listener for store events
    BlockStoreConfig -> Publisher StoreEvent
blockConfListener :: !(Publisher StoreEvent),
    -- | RocksDB database handle
    BlockStoreConfig -> DatabaseReader
blockConfDB :: !DatabaseReader,
    -- | network constants
    BlockStoreConfig -> Network
blockConfNet :: !Network,
    -- | do not index new mempool transactions
    BlockStoreConfig -> Bool
blockConfNoMempool :: !Bool,
    -- | wipe mempool at start
    BlockStoreConfig -> Bool
blockConfWipeMempool :: !Bool,
    -- | sync mempool from peers
    BlockStoreConfig -> Bool
blockConfSyncMempool :: !Bool,
    -- | disconnect syncing peer if inactive for this long
    BlockStoreConfig -> NominalDiffTime
blockConfPeerTimeout :: !NominalDiffTime,
    BlockStoreConfig -> Maybe Store
blockConfStats :: !(Maybe Metrics.Store)
  }

type BlockT m = ReaderT BlockStore m

runImport ::
  MonadLoggerIO m =>
  WriterT (ExceptT ImportException m) a ->
  BlockT m (Either ImportException a)
runImport :: forall (m :: * -> *) a.
MonadLoggerIO m =>
WriterT (ExceptT ImportException m) a
-> BlockT m (Either ImportException a)
runImport WriterT (ExceptT ImportException m) a
f =
  forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT forall a b. (a -> b) -> a -> b
$ \BlockStore
r -> forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadIO m =>
DatabaseReader -> WriterT m a -> m a
runWriter (BlockStoreConfig -> DatabaseReader
blockConfDB (BlockStore -> BlockStoreConfig
myConfig BlockStore
r)) WriterT (ExceptT ImportException m) a
f

runRocksDB :: ReaderT DatabaseReader m a -> BlockT m a
runRocksDB :: forall (m :: * -> *) a. ReaderT DatabaseReader m a -> BlockT m a
runRocksDB ReaderT DatabaseReader m a
f =
  forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT DatabaseReader m a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockStoreConfig -> DatabaseReader
blockConfDB forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockStore -> BlockStoreConfig
myConfig

instance MonadIO m => StoreReadBase (BlockT m) where
  getNetwork :: BlockT m Network
getNetwork =
    forall (m :: * -> *) a. ReaderT DatabaseReader m a -> BlockT m a
runRocksDB forall (m :: * -> *). StoreReadBase m => m Network
getNetwork
  getBestBlock :: BlockT m (Maybe BlockHash)
getBestBlock =
    forall (m :: * -> *) a. ReaderT DatabaseReader m a -> BlockT m a
runRocksDB forall (m :: * -> *). StoreReadBase m => m (Maybe BlockHash)
getBestBlock
  getBlocksAtHeight :: BlockHeight -> BlockT m [BlockHash]
getBlocksAtHeight =
    forall (m :: * -> *) a. ReaderT DatabaseReader m a -> BlockT m a
runRocksDB forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
StoreReadBase m =>
BlockHeight -> m [BlockHash]
getBlocksAtHeight
  getBlock :: BlockHash -> BlockT m (Maybe BlockData)
getBlock =
    forall (m :: * -> *) a. ReaderT DatabaseReader m a -> BlockT m a
runRocksDB forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
StoreReadBase m =>
BlockHash -> m (Maybe BlockData)
getBlock
  getTxData :: TxHash -> BlockT m (Maybe TxData)
getTxData =
    forall (m :: * -> *) a. ReaderT DatabaseReader m a -> BlockT m a
runRocksDB forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). StoreReadBase m => TxHash -> m (Maybe TxData)
getTxData
  getSpender :: OutPoint -> BlockT m (Maybe Spender)
getSpender =
    forall (m :: * -> *) a. ReaderT DatabaseReader m a -> BlockT m a
runRocksDB forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
StoreReadBase m =>
OutPoint -> m (Maybe Spender)
getSpender
  getUnspent :: OutPoint -> BlockT m (Maybe Unspent)
getUnspent =
    forall (m :: * -> *) a. ReaderT DatabaseReader m a -> BlockT m a
runRocksDB forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
StoreReadBase m =>
OutPoint -> m (Maybe Unspent)
getUnspent
  getBalance :: Address -> BlockT m (Maybe Balance)
getBalance =
    forall (m :: * -> *) a. ReaderT DatabaseReader m a -> BlockT m a
runRocksDB forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
StoreReadBase m =>
Address -> m (Maybe Balance)
getBalance
  getMempool :: BlockT m [(UnixTime, TxHash)]
getMempool =
    forall (m :: * -> *) a. ReaderT DatabaseReader m a -> BlockT m a
runRocksDB forall (m :: * -> *). StoreReadBase m => m [(UnixTime, TxHash)]
getMempool

instance MonadUnliftIO m => StoreReadExtra (BlockT m) where
  getMaxGap :: BlockT m BlockHeight
getMaxGap =
    forall (m :: * -> *) a. ReaderT DatabaseReader m a -> BlockT m a
runRocksDB forall (m :: * -> *). StoreReadExtra m => m BlockHeight
getMaxGap
  getInitialGap :: BlockT m BlockHeight
getInitialGap =
    forall (m :: * -> *) a. ReaderT DatabaseReader m a -> BlockT m a
runRocksDB forall (m :: * -> *). StoreReadExtra m => m BlockHeight
getInitialGap
  getAddressesTxs :: [Address] -> Limits -> BlockT m [TxRef]
getAddressesTxs [Address]
as =
    forall (m :: * -> *) a. ReaderT DatabaseReader m a -> BlockT m a
runRocksDB forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
StoreReadExtra m =>
[Address] -> Limits -> m [TxRef]
getAddressesTxs [Address]
as
  getAddressesUnspents :: [Address] -> Limits -> BlockT m [Unspent]
getAddressesUnspents [Address]
as =
    forall (m :: * -> *) a. ReaderT DatabaseReader m a -> BlockT m a
runRocksDB forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
StoreReadExtra m =>
[Address] -> Limits -> m [Unspent]
getAddressesUnspents [Address]
as
  getAddressUnspents :: Address -> Limits -> BlockT m [Unspent]
getAddressUnspents Address
a =
    forall (m :: * -> *) a. ReaderT DatabaseReader m a -> BlockT m a
runRocksDB forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
StoreReadExtra m =>
Address -> Limits -> m [Unspent]
getAddressUnspents Address
a
  getAddressTxs :: Address -> Limits -> BlockT m [TxRef]
getAddressTxs Address
a =
    forall (m :: * -> *) a. ReaderT DatabaseReader m a -> BlockT m a
runRocksDB forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
StoreReadExtra m =>
Address -> Limits -> m [TxRef]
getAddressTxs Address
a
  getNumTxData :: UnixTime -> BlockT m [TxData]
getNumTxData =
    forall (m :: * -> *) a. ReaderT DatabaseReader m a -> BlockT m a
runRocksDB forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). StoreReadExtra m => UnixTime -> m [TxData]
getNumTxData
  getBalances :: [Address] -> BlockT m [Balance]
getBalances =
    forall (m :: * -> *) a. ReaderT DatabaseReader m a -> BlockT m a
runRocksDB forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). StoreReadExtra m => [Address] -> m [Balance]
getBalances
  xPubBals :: XPubSpec -> BlockT m [XPubBal]
xPubBals =
    forall (m :: * -> *) a. ReaderT DatabaseReader m a -> BlockT m a
runRocksDB forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). StoreReadExtra m => XPubSpec -> m [XPubBal]
xPubBals
  xPubUnspents :: XPubSpec -> [XPubBal] -> Limits -> BlockT m [XPubUnspent]
xPubUnspents XPubSpec
x [XPubBal]
l =
    forall (m :: * -> *) a. ReaderT DatabaseReader m a -> BlockT m a
runRocksDB forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 =
    forall (m :: * -> *) a. ReaderT DatabaseReader m a -> BlockT m a
runRocksDB forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
StoreReadExtra m =>
XPubSpec -> [XPubBal] -> Limits -> m [TxRef]
xPubTxs XPubSpec
x [XPubBal]
l
  xPubTxCount :: XPubSpec -> [XPubBal] -> BlockT m BlockHeight
xPubTxCount XPubSpec
x =
    forall (m :: * -> *) a. ReaderT DatabaseReader m a -> BlockT m a
runRocksDB forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 <- forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO forall a. Maybe a
Nothing
  TVar (HashMap TxHash PendingTx)
ts <- forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO forall k v. HashMap k v
HashMap.empty
  TVar (HashSet TxHash)
rq <- forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO forall a. HashSet a
HashSet.empty
  Inbox BlockStoreMessage
inbox <- forall (m :: * -> *) msg. MonadIO m => m (Inbox msg)
newInbox
  Maybe StoreMetrics
metrics <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *). MonadIO m => Store -> m StoreMetrics
newStoreMetrics (BlockStoreConfig -> Maybe Store
blockConfStats BlockStoreConfig
cfg)
  let r :: BlockStore
r =
        BlockStore
          { myMailbox :: Mailbox BlockStoreMessage
myMailbox = forall msg. Inbox msg -> Mailbox msg
inboxToMailbox Inbox BlockStoreMessage
inbox,
            myConfig :: BlockStoreConfig
myConfig = BlockStoreConfig
cfg,
            myPeer :: TVar (Maybe Syncing)
myPeer = TVar (Maybe Syncing)
pb,
            myTxs :: TVar (HashMap TxHash PendingTx)
myTxs = TVar (HashMap TxHash PendingTx)
ts,
            requested :: TVar (HashSet TxHash)
requested = TVar (HashSet TxHash)
rq,
            myMetrics :: Maybe StoreMetrics
myMetrics = Maybe StoreMetrics
metrics
          }
  forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> (Async a -> m b) -> m b
withAsync (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall {b}. Inbox BlockStoreMessage -> ReaderT BlockStore m b
go Inbox BlockStoreMessage
inbox) BlockStore
r) forall a b. (a -> b) -> a -> b
$ \Async Any
a -> do
    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
      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" forall a b. (a -> b) -> a -> b
$
        Text
"Deleting " forall a. Semigroup a => a -> a -> a
<> forall a b. ConvertibleStrings a b => a -> b
cs (forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length t (a, TxHash)
txs)) forall a. Semigroup a => a -> a -> a
<> Text
" transactions"
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ t (a, TxHash)
txs forall a b. (a -> b) -> a -> b
$ \(a
_, TxHash
th) -> forall (m :: * -> *). MonadImport m => Bool -> TxHash -> m ()
deleteUnconfirmedTx Bool
False TxHash
th
    wipe_it :: [(a, TxHash)] -> ReaderT BlockStore m ()
wipe_it [(a, TxHash)]
txs = do
      let ([(a, TxHash)]
txs1, [(a, TxHash)]
txs2) = forall a. Int -> [a] -> ([a], [a])
splitAt Int
1000 [(a, TxHash)]
txs
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(a, TxHash)]
txs1) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a.
MonadLoggerIO m =>
WriterT (ExceptT ImportException m) a
-> BlockT m (Either ImportException a)
runImport (forall {m :: * -> *} {t :: * -> *} {a}.
(Foldable t, MonadError ImportException m, MonadLoggerIO m,
 StoreReadBase m, StoreWrite m) =>
t (a, TxHash) -> m ()
del [(a, TxHash)]
txs1) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Left ImportException
e -> do
            $(logErrorS) Text
"BlockStore" forall a b. (a -> b) -> a -> b
$
              Text
"Could not wipe mempool: " forall a. Semigroup a => a -> a -> a
<> forall a b. ConvertibleStrings a b => a -> b
cs (forall a. Show a => a -> String
show ImportException
e)
            forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO ImportException
e
          Right () -> [(a, TxHash)] -> ReaderT BlockStore m ()
wipe_it [(a, TxHash)]
txs2
    wipe :: ReaderT BlockStore m ()
wipe
      | BlockStoreConfig -> Bool
blockConfWipeMempool BlockStoreConfig
cfg =
          forall (m :: * -> *). StoreReadBase m => m [(UnixTime, TxHash)]
getMempool forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {m :: * -> *} {a}.
MonadLoggerIO m =>
[(a, TxHash)] -> ReaderT BlockStore m ()
wipe_it
      | Bool
otherwise =
          forall (m :: * -> *) a. Monad m => a -> m a
return ()
    ini :: ReaderT BlockStore m ()
ini =
      forall (m :: * -> *) a.
MonadLoggerIO m =>
WriterT (ExceptT ImportException m) a
-> BlockT m (Either ImportException a)
runImport forall (m :: * -> *). MonadImport m => m ()
initBest forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left ImportException
e -> do
          $(logErrorS) Text
"BlockStore" forall a b. (a -> b) -> a -> b
$
            Text
"Could not initialize: " forall a. Semigroup a => a -> a -> a
<> forall a b. ConvertibleStrings a b => a -> b
cs (forall a. Show a => a -> String
show ImportException
e)
          forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO ImportException
e
        Right () -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    run :: Inbox BlockStoreMessage -> ReaderT BlockStore m b
run Inbox BlockStoreMessage
inbox =
      forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> (Async a -> m b) -> m b
withAsync (forall (m :: * -> *).
MonadLoggerIO m =>
Mailbox BlockStoreMessage -> m ()
pingMe (forall msg. Inbox msg -> Mailbox msg
inboxToMailbox Inbox BlockStoreMessage
inbox)) forall a b. (a -> b) -> a -> b
$
        forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$
          forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$
            forall (mbox :: * -> *) (m :: * -> *) msg.
(InChan mbox, MonadIO m) =>
mbox msg -> m msg
receive Inbox BlockStoreMessage
inbox
              forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
(MonadUnliftIO m, MonadLoggerIO m) =>
BlockStoreMessage -> BlockT m ()
processBlockStoreMessage

isInSync :: MonadLoggerIO m => BlockT m Bool
isInSync :: forall (m :: * -> *). MonadLoggerIO m => BlockT m Bool
isInSync =
  forall (m :: * -> *). StoreReadBase m => m (Maybe BlockHash)
getBestBlock 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"
      forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO BlockException
Uninitialized
    Just BlockHash
bb -> do
      BlockNode
cb <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (BlockStoreConfig -> Chain
blockConfChain forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockStore -> BlockStoreConfig
myConfig) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). MonadIO m => Chain -> m BlockNode
chainGetBest
      if BlockHeader -> BlockHash
headerHash (BlockNode -> BlockHeader
nodeHeader BlockNode
cb) forall a. Eq a => a -> a -> Bool
== BlockHash
bb
        then forall (m :: * -> *).
(MonadLoggerIO m, MonadReader BlockStore m) =>
m ()
clearSyncingState forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        else 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 <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (BlockStoreConfig -> Bool
blockConfNoMempool forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockStore -> BlockStoreConfig
myConfig)
  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 <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (BlockStoreConfig -> Bool
blockConfSyncMempool forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockStore -> BlockStoreConfig
myConfig)
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
s BlockT m ()
f

mempool :: (MonadUnliftIO m, MonadLoggerIO m) => Peer -> BlockT m ()
mempool :: forall (m :: * -> *).
(MonadUnliftIO m, MonadLoggerIO m) =>
Peer -> BlockT m ()
mempool Peer
p =
  forall (m :: * -> *). Monad m => BlockT m () -> BlockT m ()
guardMempool forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Monad m => BlockT m () -> BlockT m ()
syncMempool forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *). MonadLoggerIO m => BlockT m Bool
isInSync forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
s -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
s forall a b. (a -> b) -> a -> b
$ do
      $(logDebugS) Text
"BlockStore" forall a b. (a -> b) -> a -> b
$
        Text
"Requesting mempool from peer: " forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
      Message
MMempool 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 = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT forall a b. (a -> b) -> a -> b
$ do
  forall (m :: * -> *).
(MonadLoggerIO m, MonadReader BlockStore m) =>
Peer -> m Bool
checkPeer Peer
peer forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Bool
True -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Bool
False -> do
      $(logErrorS) Text
"BlockStore" forall a b. (a -> b) -> a -> b
$
        Text
"Non-syncing peer "
          forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
peer
          forall a. Semigroup a => a -> a -> a
<> Text
" sent me a block: "
          forall a. Semigroup a => a -> a -> a
<> BlockHash -> Text
blockHashToHex BlockHash
blockhash
      String -> PeerException
PeerMisbehaving String
"Sent unexpected block" forall (m :: * -> *). MonadIO m => PeerException -> Peer -> m ()
`killPeer` Peer
peer
      forall (m :: * -> *) a. MonadPlus m => m a
mzero
  BlockNode
node <-
    forall (m :: * -> *).
(MonadLoggerIO m, MonadReader BlockStore m) =>
BlockHash -> m (Maybe BlockNode)
getBlockNode BlockHash
blockhash forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just BlockNode
b -> forall (m :: * -> *) a. Monad m => a -> m a
return BlockNode
b
      Maybe BlockNode
Nothing -> do
        $(logErrorS) Text
"BlockStore" forall a b. (a -> b) -> a -> b
$
          Text
"Peer "
            forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
peer
            forall a. Semigroup a => a -> a -> a
<> Text
" sent unknown block: "
            forall a. Semigroup a => a -> a -> a
<> BlockHash -> Text
blockHashToHex BlockHash
blockhash
        String -> PeerException
PeerMisbehaving String
"Sent unknown block" forall (m :: * -> *). MonadIO m => PeerException -> Peer -> m ()
`killPeer` Peer
peer
        forall (m :: * -> *) a. MonadPlus m => m a
mzero
  $(logDebugS) Text
"BlockStore" forall a b. (a -> b) -> a -> b
$
    Text
"Processing block: "
      forall a. Semigroup a => a -> a -> a
<> BlockNode -> Maybe Block -> Text
blockText BlockNode
node forall a. Maybe a
Nothing
      forall a. Semigroup a => a -> a -> a
<> Text
" from peer: "
      forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
peer
  forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
MonadIO m =>
Maybe Block -> BlockT m a -> BlockT m a
notify (forall a. a -> Maybe a
Just Block
block) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a.
MonadLoggerIO m =>
WriterT (ExceptT ImportException m) a
-> BlockT m (Either ImportException a)
runImport (forall (m :: * -> *).
MonadImport m =>
Block -> BlockNode -> m (BlockData, [TxData])
importBlock Block
block BlockNode
node) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left ImportException
e -> forall {m :: * -> *} {a}.
(MonadLogger m, Show a, MonadIO m) =>
a -> m ()
failure ImportException
e
      Right (BlockData, [TxData])
_ -> forall {m :: * -> *}.
(MonadLoggerIO m, MonadUnliftIO m) =>
BlockNode -> ReaderT BlockStore m ()
success BlockNode
node
  where
    header :: BlockHeader
header = Block -> BlockHeader
blockHeader Block
block
    blockhash :: BlockHash
blockhash = BlockHeader -> BlockHash
headerHash BlockHeader
header
    hexhash :: Text
hexhash = BlockHash -> Text
blockHashToHex BlockHash
blockhash
    success :: BlockNode -> ReaderT BlockStore m ()
success BlockNode
node = do
      $(logInfoS) Text
"BlockStore" forall a b. (a -> b) -> a -> b
$
        Text
"Best block: " forall a. Semigroup a => a -> a -> a
<> BlockNode -> Maybe Block -> Text
blockText BlockNode
node (forall a. a -> Maybe a
Just Block
block)
      forall (m :: * -> *).
(MonadReader BlockStore m, MonadIO m) =>
BlockHash -> m ()
removeSyncingBlock forall a b. (a -> b) -> a -> b
$ BlockHeader -> BlockHash
headerHash forall a b. (a -> b) -> a -> b
$ BlockNode -> BlockHeader
nodeHeader BlockNode
node
      forall (m :: * -> *). (MonadIO m, MonadReader BlockStore m) => m ()
touchPeer
      forall (m :: * -> *). MonadLoggerIO m => BlockT m Bool
isInSync forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Bool
False -> forall (m :: * -> *). MonadLoggerIO m => BlockT m ()
syncMe
        Bool
True -> do
          forall (m :: * -> *).
(StoreReadBase m, MonadLoggerIO m, MonadReader BlockStore m) =>
m ()
updateOrphans
          forall (m :: * -> *).
(MonadUnliftIO m, MonadLoggerIO m) =>
Peer -> BlockT m ()
mempool Peer
peer
    failure :: a -> m ()
failure a
e = do
      $(logErrorS) Text
"BlockStore" forall a b. (a -> b) -> a -> b
$
        Text
"Error importing block "
          forall a. Semigroup a => a -> a -> a
<> Text
hexhash
          forall a. Semigroup a => a -> a -> a
<> Text
" from peer: "
          forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
peer
          forall a. Semigroup a => a -> a -> a
<> Text
": "
          forall a. Semigroup a => a -> a -> a
<> forall a b. ConvertibleStrings a b => a -> b
cs (forall a. Show a => a -> String
show a
e)
      forall (m :: * -> *). MonadIO m => PeerException -> Peer -> m ()
killPeer (String -> PeerException
PeerMisbehaving (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 =
  forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> TVar (Maybe Syncing)
myPeer forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \TVar (Maybe Syncing)
box ->
    forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$
      forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Maybe Syncing)
box forall a b. (a -> b) -> a -> b
$ \case
        Maybe Syncing
Nothing -> forall a. Maybe a
Nothing
        Just Syncing
x -> forall a. a -> Maybe a
Just Syncing
x {syncingBlocks :: [BlockHash]
syncingBlocks = [BlockHash]
hs}

getSyncingBlocks :: (MonadReader BlockStore m, MonadIO m) => m [BlockHash]
getSyncingBlocks :: forall (m :: * -> *).
(MonadReader BlockStore m, MonadIO m) =>
m [BlockHash]
getSyncingBlocks =
  forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> TVar (Maybe Syncing)
myPeer forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe Syncing
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return []
    Just Syncing
x -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Syncing -> [BlockHash]
syncingBlocks Syncing
x

addSyncingBlocks ::
  (MonadReader BlockStore m, MonadIO m) =>
  [BlockHash] ->
  m ()
addSyncingBlocks :: forall (m :: * -> *).
(MonadReader BlockStore m, MonadIO m) =>
[BlockHash] -> m ()
addSyncingBlocks [BlockHash]
hs =
  forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> TVar (Maybe Syncing)
myPeer forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \TVar (Maybe Syncing)
box ->
    forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$
      forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Maybe Syncing)
box forall a b. (a -> b) -> a -> b
$ \case
        Maybe Syncing
Nothing -> forall a. Maybe a
Nothing
        Just Syncing
x -> forall a. a -> Maybe a
Just Syncing
x {syncingBlocks :: [BlockHash]
syncingBlocks = Syncing -> [BlockHash]
syncingBlocks Syncing
x forall a. Semigroup a => a -> a -> a
<> [BlockHash]
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 <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> TVar (Maybe Syncing)
myPeer
  forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$
    forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Maybe Syncing)
box forall a b. (a -> b) -> a -> b
$ \case
      Maybe Syncing
Nothing -> forall a. Maybe a
Nothing
      Just Syncing
x -> forall a. a -> Maybe a
Just Syncing
x {syncingBlocks :: [BlockHash]
syncingBlocks = forall a. Eq a => a -> [a] -> [a]
delete BlockHash
h (Syncing -> [BlockHash]
syncingBlocks Syncing
x)}

checkPeer :: (MonadLoggerIO m, MonadReader BlockStore m) => Peer -> m Bool
checkPeer :: forall (m :: * -> *).
(MonadLoggerIO m, MonadReader BlockStore m) =>
Peer -> m Bool
checkPeer Peer
p =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Syncing -> Peer
syncingPeer forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
(MonadIO m, MonadReader BlockStore m) =>
m (Maybe Syncing)
getSyncingState forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe Peer
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    Just Peer
p' -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Peer
p 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 =
  forall (m :: * -> *).
MonadIO m =>
BlockHash -> Chain -> m (Maybe BlockNode)
chainGetBlock BlockHash
blockhash forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (BlockStoreConfig -> Chain
blockConfChain forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockStore -> BlockStoreConfig
myConfig)

processNoBlocks ::
  MonadLoggerIO m =>
  Peer ->
  [BlockHash] ->
  BlockT m ()
processNoBlocks :: forall (m :: * -> *).
MonadLoggerIO m =>
Peer -> [BlockHash] -> BlockT m ()
processNoBlocks Peer
p [BlockHash]
hs = do
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a b. [a] -> [b] -> [(a, b)]
zip [(Int
1 :: Int) ..] [BlockHash]
hs) forall a b. (a -> b) -> a -> b
$ \(Int
i, BlockHash
h) ->
    $(logErrorS) Text
"BlockStore" forall a b. (a -> b) -> a -> b
$
      Text
"Block "
        forall a. Semigroup a => a -> a -> a
<> forall a b. ConvertibleStrings a b => a -> b
cs (forall a. Show a => a -> String
show Int
i)
        forall a. Semigroup a => a -> a -> a
<> Text
"/"
        forall a. Semigroup a => a -> a -> a
<> forall a b. ConvertibleStrings a b => a -> b
cs (forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [BlockHash]
hs))
        forall a. Semigroup a => a -> a -> a
<> Text
" "
        forall a. Semigroup a => a -> a -> a
<> BlockHash -> Text
blockHashToHex BlockHash
h
        forall a. Semigroup a => a -> a -> a
<> Text
" not found by peer: "
        forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
  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 = forall (m :: * -> *). Monad m => BlockT m () -> BlockT m ()
guardMempool forall a b. (a -> b) -> a -> b
$ do
  UTCTime
t <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  $(logDebugS) Text
"BlockManager" forall a b. (a -> b) -> a -> b
$
    Text
"Received tx "
      forall a. Semigroup a => a -> a -> a
<> TxHash -> Text
txHashToHex (Tx -> TxHash
txHash Tx
tx)
      forall a. Semigroup a => a -> a -> a
<> Text
" by peer: "
      forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
  forall (m :: * -> *). MonadIO m => PendingTx -> BlockT m ()
addPendingTx forall a b. (a -> b) -> a -> b
$ UTCTime -> Tx -> HashSet TxHash -> PendingTx
PendingTx UTCTime
t Tx
tx forall a. HashSet a
HashSet.empty

pruneOrphans :: MonadIO m => BlockT m ()
pruneOrphans :: forall (m :: * -> *). MonadIO m => BlockT m ()
pruneOrphans = forall (m :: * -> *). Monad m => BlockT m () -> BlockT m ()
guardMempool forall a b. (a -> b) -> a -> b
$ do
  TVar (HashMap TxHash PendingTx)
ts <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> TVar (HashMap TxHash PendingTx)
myTxs
  UTCTime
now <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (HashMap TxHash PendingTx)
ts forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v k. (v -> Bool) -> HashMap k v -> HashMap k v
HashMap.filter forall a b. (a -> b) -> a -> b
$ \PendingTx
p ->
    UTCTime
now UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` PendingTx -> UTCTime
pendingTxTime PendingTx
p 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 <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> TVar (HashMap TxHash PendingTx)
myTxs
  TVar (HashSet TxHash)
rq <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> TVar (HashSet TxHash)
requested
  forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ do
    forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (HashMap TxHash PendingTx)
ts forall a b. (a -> b) -> a -> b
$ forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert TxHash
th PendingTx
p
    forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (HashSet TxHash)
rq forall a b. (a -> b) -> a -> b
$ forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HashSet.delete TxHash
th
    forall k v. HashMap k v -> Int
HashMap.size forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TVar a -> STM a
readTVar TVar (HashMap TxHash PendingTx)
ts
  forall (m :: * -> *). MonadIO m => BlockT m ()
setPendingTxs
  where
    th :: TxHash
th = Tx -> TxHash
txHash (PendingTx -> Tx
pendingTx PendingTx
p)

addRequestedTx :: MonadIO m => TxHash -> BlockT m ()
addRequestedTx :: forall (m :: * -> *). MonadIO m => TxHash -> BlockT m ()
addRequestedTx TxHash
th = do
  TVar (HashSet TxHash)
qbox <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> TVar (HashSet TxHash)
requested
  forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (HashSet TxHash)
qbox forall a b. (a -> b) -> a -> b
$ forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HashSet.insert TxHash
th
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async forall a b. (a -> b) -> a -> b
$ do
    forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay Int
20000000
    forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (HashSet TxHash)
qbox forall a b. (a -> b) -> a -> b
$ 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 <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> TVar (HashMap TxHash PendingTx)
myTxs
  TVar (HashSet TxHash)
qbox <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> TVar (HashSet TxHash)
requested
  forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ do
    HashMap TxHash PendingTx
ts <- forall a. TVar a -> STM a
readTVar TVar (HashMap TxHash PendingTx)
tbox
    HashSet TxHash
rs <- forall a. TVar a -> STM a
readTVar TVar (HashSet TxHash)
qbox
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
      TxHash
th forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool
`HashMap.member` HashMap TxHash PendingTx
ts
        Bool -> Bool -> Bool
|| TxHash
th 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 <-
    forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> TVar (HashMap TxHash PendingTx)
myTxs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \TVar (HashMap TxHash PendingTx)
box -> forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ do
      HashMap TxHash PendingTx
pending <- forall a. TVar a -> STM a
readTVar TVar (HashMap TxHash PendingTx)
box
      let ([PendingTx]
selected, HashMap TxHash PendingTx
rest) = HashMap TxHash PendingTx -> ([PendingTx], HashMap TxHash PendingTx)
select HashMap TxHash PendingTx
pending
      forall a. TVar a -> a -> STM ()
writeTVar TVar (HashMap TxHash PendingTx)
box HashMap TxHash PendingTx
rest
      forall (m :: * -> *) a. Monad m => a -> m a
return ([PendingTx]
selected)
  forall (m :: * -> *). MonadIO m => BlockT m ()
setPendingTxs
  forall (m :: * -> *) a. Monad m => a -> m a
return [PendingTx]
selected
  where
    select :: HashMap TxHash PendingTx -> ([PendingTx], HashMap TxHash PendingTx)
select HashMap TxHash PendingTx
pend =
      let eligible :: HashMap TxHash PendingTx
eligible = forall v k. (v -> Bool) -> HashMap k v -> HashMap k v
HashMap.filter (forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. PendingTx -> HashSet TxHash
pendingDeps) HashMap TxHash PendingTx
pend
          orphans :: HashMap TxHash PendingTx
orphans = forall k v w.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k w -> HashMap k v
HashMap.difference HashMap TxHash PendingTx
pend HashMap TxHash PendingTx
eligible
          selected :: [PendingTx]
selected = forall a. Int -> [a] -> [a]
take Int
i forall a b. (a -> b) -> a -> b
$ HashMap TxHash PendingTx -> [PendingTx]
sortit HashMap TxHash PendingTx
eligible
          remaining :: HashMap TxHash PendingTx
remaining = forall v k. (v -> Bool) -> HashMap k v -> HashMap k v
HashMap.filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [PendingTx]
selected) HashMap TxHash PendingTx
eligible
       in ([PendingTx]
selected, HashMap TxHash PendingTx
remaining forall a. Semigroup a => a -> a -> a
<> HashMap TxHash PendingTx
orphans)
    sortit :: HashMap TxHash PendingTx -> [PendingTx]
sortit HashMap TxHash PendingTx
m =
      let sorted :: [(BlockHeight, Tx)]
sorted = [Tx] -> [(BlockHeight, Tx)]
sortTxs forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map PendingTx -> Tx
pendingTx forall a b. (a -> b) -> a -> b
$ forall k v. HashMap k v -> [v]
HashMap.elems HashMap TxHash PendingTx
m
          txids :: [TxHash]
txids = forall a b. (a -> b) -> [a] -> [b]
map (Tx -> TxHash
txHash forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(BlockHeight, Tx)]
sorted
       in forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
`HashMap.lookup` HashMap TxHash PendingTx
m) [TxHash]
txids

fulfillOrphans :: MonadIO m => BlockStore -> TxHash -> m ()
fulfillOrphans :: forall (m :: * -> *). MonadIO m => BlockStore -> TxHash -> m ()
fulfillOrphans BlockStore
block_read TxHash
th =
  forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (HashMap TxHash PendingTx)
box (forall v1 v2 k. (v1 -> v2) -> HashMap k v1 -> HashMap k v2
HashMap.map PendingTx -> PendingTx
fulfill)
  where
    box :: TVar (HashMap TxHash PendingTx)
box = BlockStore -> TVar (HashMap TxHash PendingTx)
myTxs BlockStore
block_read
    fulfill :: PendingTx -> PendingTx
fulfill PendingTx
p = PendingTx
p {pendingDeps :: HashSet TxHash
pendingDeps = forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HashSet.delete TxHash
th (PendingTx -> HashSet TxHash
pendingDeps PendingTx
p)}

updateOrphans ::
  ( StoreReadBase m,
    MonadLoggerIO m,
    MonadReader BlockStore m
  ) =>
  m ()
updateOrphans :: forall (m :: * -> *).
(StoreReadBase m, MonadLoggerIO m, MonadReader BlockStore m) =>
m ()
updateOrphans = do
  TVar (HashMap TxHash PendingTx)
box <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> TVar (HashMap TxHash PendingTx)
myTxs
  HashMap TxHash PendingTx
pending <- forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar (HashMap TxHash PendingTx)
box
  let orphans :: HashMap TxHash PendingTx
orphans = forall v k. (v -> Bool) -> HashMap k v -> HashMap k v
HashMap.filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. PendingTx -> HashSet TxHash
pendingDeps) HashMap TxHash PendingTx
pending
  HashMap TxHash (Maybe PendingTx)
updated <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM HashMap TxHash PendingTx
orphans forall a b. (a -> b) -> a -> b
$ \PendingTx
p -> do
    let tx :: Tx
tx = PendingTx -> Tx
pendingTx PendingTx
p
    forall {m :: * -> *}. StoreReadBase m => TxHash -> m Bool
exists (Tx -> TxHash
txHash Tx
tx) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Bool
True -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
      Bool
False -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {m :: * -> *}. StoreReadBase m => PendingTx -> m PendingTx
fill_deps PendingTx
p
  let pruned :: HashMap TxHash PendingTx
pruned = forall v1 v2 k. (v1 -> v2) -> HashMap k v1 -> HashMap k v2
HashMap.map forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall v k. (v -> Bool) -> HashMap k v -> HashMap k v
HashMap.filter forall a. Maybe a -> Bool
isJust HashMap TxHash (Maybe PendingTx)
updated
  forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> a -> STM ()
writeTVar TVar (HashMap TxHash PendingTx)
box HashMap TxHash PendingTx
pruned
  where
    exists :: TxHash -> m Bool
exists TxHash
th =
      forall (m :: * -> *). StoreReadBase m => TxHash -> m (Maybe TxData)
getTxData TxHash
th forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe TxData
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Just TxData {txDataDeleted :: TxData -> Bool
txDataDeleted = Bool
True} -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Just TxData {txDataDeleted :: TxData -> Bool
txDataDeleted = Bool
False} -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    prev_utxos :: Tx -> f [Unspent]
prev_utxos Tx
tx = forall a. [Maybe a] -> [a]
catMaybes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *).
StoreReadBase m =>
OutPoint -> m (Maybe Unspent)
getUnspent forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxIn -> OutPoint
prevOutput) (Tx -> [TxIn]
txIn Tx
tx)
    fulfill :: PendingTx -> Unspent -> PendingTx
fulfill PendingTx
p Unspent
unspent =
      let unspent_hash :: TxHash
unspent_hash = OutPoint -> TxHash
outPointHash (Unspent -> OutPoint
unspentPoint Unspent
unspent)
          new_deps :: HashSet TxHash
new_deps = forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HashSet.delete TxHash
unspent_hash (PendingTx -> HashSet TxHash
pendingDeps PendingTx
p)
       in PendingTx
p {pendingDeps :: HashSet TxHash
pendingDeps = HashSet TxHash
new_deps}
    fill_deps :: PendingTx -> m PendingTx
fill_deps PendingTx
p = do
      let tx :: Tx
tx = PendingTx -> Tx
pendingTx PendingTx
p
      [Unspent]
unspents <- forall {f :: * -> *}. StoreReadBase f => Tx -> f [Unspent]
prev_utxos Tx
tx
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl PendingTx -> Unspent -> PendingTx
fulfill PendingTx
p [Unspent]
unspents

newOrphanTx ::
  MonadLoggerIO m =>
  BlockStore ->
  UTCTime ->
  Tx ->
  WriterT m ()
newOrphanTx :: forall (m :: * -> *).
MonadLoggerIO m =>
BlockStore -> UTCTime -> Tx -> WriterT m ()
newOrphanTx BlockStore
block_read UTCTime
time Tx
tx = do
  $(logDebugS) Text
"BlockStore" forall a b. (a -> b) -> a -> b
$
    Text
"Import tx "
      forall a. Semigroup a => a -> a -> a
<> TxHash -> Text
txHashToHex (Tx -> TxHash
txHash Tx
tx)
      forall a. Semigroup a => a -> a -> a
<> Text
": Orphan"
  let box :: TVar (HashMap TxHash PendingTx)
box = BlockStore -> TVar (HashMap TxHash PendingTx)
myTxs BlockStore
block_read
  [Unspent]
unspents <- forall a. [Maybe a] -> [a]
catMaybes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *).
StoreReadBase m =>
OutPoint -> m (Maybe Unspent)
getUnspent [OutPoint]
prevs
  let unspent_set :: HashSet OutPoint
unspent_set = forall a. (Eq a, Hashable a) => [a] -> HashSet a
HashSet.fromList (forall a b. (a -> b) -> [a] -> [b]
map Unspent -> OutPoint
unspentPoint [Unspent]
unspents)
      missing_set :: HashSet OutPoint
missing_set = 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 = forall b a.
(Hashable b, Eq b) =>
(a -> b) -> HashSet a -> HashSet b
HashSet.map OutPoint -> TxHash
outPointHash HashSet OutPoint
missing_set
  forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (HashMap TxHash PendingTx)
box forall a b. (a -> b) -> a -> b
$
    forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert
      (Tx -> TxHash
txHash Tx
tx)
      PendingTx
        { pendingTxTime :: UTCTime
pendingTxTime = UTCTime
time,
          pendingTx :: Tx
pendingTx = Tx
tx,
          pendingDeps :: HashSet TxHash
pendingDeps = HashSet TxHash
missing_txs
        }
  where
    prev_set :: HashSet OutPoint
prev_set = forall a. (Eq a, Hashable a) => [a] -> HashSet a
HashSet.fromList [OutPoint]
prevs
    prevs :: [OutPoint]
prevs = forall a b. (a -> b) -> [a] -> [b]
map TxIn -> OutPoint
prevOutput (Tx -> [TxIn]
txIn Tx
tx)

importMempoolTx ::
  (MonadLoggerIO m, MonadError ImportException m) =>
  BlockStore ->
  UTCTime ->
  Tx ->
  WriterT m Bool
importMempoolTx :: forall (m :: * -> *).
(MonadLoggerIO m, MonadError ImportException m) =>
BlockStore -> UTCTime -> Tx -> WriterT m Bool
importMempoolTx BlockStore
block_read UTCTime
time Tx
tx =
  forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError ReaderT Writer m Bool
new_mempool_tx 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
      forall (m :: * -> *).
MonadLoggerIO m =>
BlockStore -> UTCTime -> Tx -> WriterT m ()
newOrphanTx BlockStore
block_read UTCTime
time Tx
tx
      forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    handle_error ImportException
_ = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    seconds :: UnixTime
seconds = 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 =
      forall (m :: * -> *). MonadImport m => Tx -> UnixTime -> m Bool
newMempoolTx Tx
tx UnixTime
seconds forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Bool
True -> do
          $(logInfoS) Text
"BlockStore" forall a b. (a -> b) -> a -> b
$
            Text
"Import tx "
              forall a. Semigroup a => a -> a -> a
<> TxHash -> Text
txHashToHex (Tx -> TxHash
txHash Tx
tx)
              forall a. Semigroup a => a -> a -> a
<> Text
": OK"
          forall (m :: * -> *). MonadIO m => BlockStore -> TxHash -> m ()
fulfillOrphans BlockStore
block_read TxHash
tx_hash
          forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        Bool
False -> do
          $(logDebugS) Text
"BlockStore" forall a b. (a -> b) -> a -> b
$
            Text
"Import tx "
              forall a. Semigroup a => a -> a -> a
<> TxHash -> Text
txHashToHex (Tx -> TxHash
txHash Tx
tx)
              forall a. Semigroup a => a -> a -> a
<> Text
": Already imported"
          forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

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 <- forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
HashSet.union HashSet TxHash
e forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Eq a, Hashable a) => [a] -> HashSet a
HashSet.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). StoreReadBase m => m [(UnixTime, TxHash)]
getMempool
  a
x <- BlockT m a
go
  HashSet TxHash
new <- forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
HashSet.union HashSet TxHash
e forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Eq a, Hashable a) => [a] -> HashSet a
HashSet.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). StoreReadBase m => m [(UnixTime, TxHash)]
getMempool
  Publisher StoreEvent
l <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (BlockStoreConfig -> Publisher StoreEvent
blockConfListener forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockStore -> BlockStoreConfig
myConfig)
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (HashSet TxHash
old forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
`HashSet.difference` HashSet TxHash
new) forall a b. (a -> b) -> a -> b
$ \TxHash
h ->
    forall (m :: * -> *) msg. MonadIO m => msg -> Publisher msg -> m ()
publish (TxHash -> StoreEvent
StoreMempoolDelete TxHash
h) Publisher StoreEvent
l
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (HashSet TxHash
new forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
`HashSet.difference` HashSet TxHash
old) forall a b. (a -> b) -> a -> b
$ \TxHash
h ->
    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 -> forall (m :: * -> *) msg. MonadIO m => msg -> Publisher msg -> m ()
publish (BlockHash -> StoreEvent
StoreBestBlock (BlockHeader -> BlockHash
headerHash (Block -> BlockHeader
blockHeader Block
b))) Publisher StoreEvent
l
    Maybe Block
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
  forall (m :: * -> *) a. Monad m => a -> m a
return a
x
  where
    e :: HashSet TxHash
e = case Maybe Block
block of
      Just Block
b -> forall a. (Eq a, Hashable a) => [a] -> HashSet a
HashSet.fromList (forall a b. (a -> b) -> [a] -> [b]
map Tx -> TxHash
txHash (Block -> [Tx]
blockTxns Block
b))
      Maybe Block
Nothing -> forall a. HashSet a
HashSet.empty

processMempool :: MonadLoggerIO m => BlockT m ()
processMempool :: forall (m :: * -> *). MonadLoggerIO m => BlockT m ()
processMempool = forall (m :: * -> *). Monad m => BlockT m () -> BlockT m ()
guardMempool forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
MonadIO m =>
Maybe Block -> BlockT m a -> BlockT m a
notify forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ do
  [PendingTx]
txs <- forall (m :: * -> *). MonadIO m => Int -> BlockT m [PendingTx]
pendingTxs Int
2000
  BlockStore
block_read <- forall r (m :: * -> *). MonadReader r m => m r
ask
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PendingTx]
txs) (forall {m :: * -> *} {t :: * -> *}.
(Traversable t, MonadLoggerIO m) =>
BlockStore -> t PendingTx -> ReaderT BlockStore m ()
import_txs BlockStore
block_read [PendingTx]
txs)
  where
    run_import :: BlockStore -> PendingTx -> WriterT m Bool
run_import BlockStore
block_read PendingTx
p =
      let t :: Tx
t = PendingTx -> Tx
pendingTx PendingTx
p
          h :: TxHash
h = Tx -> TxHash
txHash Tx
t
       in forall (m :: * -> *).
(MonadLoggerIO m, MonadError ImportException m) =>
BlockStore -> UTCTime -> Tx -> WriterT m Bool
importMempoolTx BlockStore
block_read (PendingTx -> UTCTime
pendingTxTime PendingTx
p) (PendingTx -> Tx
pendingTx PendingTx
p)
    import_txs :: BlockStore -> t PendingTx -> ReaderT BlockStore m ()
import_txs BlockStore
block_read t PendingTx
txs =
      let r :: ReaderT Writer (ExceptT ImportException m) (t Bool)
r = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall {m :: * -> *}.
(MonadLoggerIO m, MonadError ImportException m) =>
BlockStore -> PendingTx -> WriterT m Bool
run_import BlockStore
block_read) t PendingTx
txs
       in forall (m :: * -> *) a.
MonadLoggerIO m =>
WriterT (ExceptT ImportException m) a
-> BlockT m (Either ImportException a)
runImport ReaderT Writer (ExceptT ImportException m) (t Bool)
r forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Left ImportException
e -> forall {m :: * -> *} {e} {b}.
(MonadLogger m, MonadIO m, Exception e) =>
e -> m b
report_error ImportException
e
            Right t Bool
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    report_error :: e -> m b
report_error e
e = do
      $(logErrorS) Text
"BlockImport" forall a b. (a -> b) -> a -> b
$
        Text
"Error processing mempool: " forall a. Semigroup a => a -> a -> a
<> forall a b. ConvertibleStrings a b => a -> b
cs (forall a. Show a => a -> String
show e
e)
      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 = forall (m :: * -> *). Monad m => BlockT m () -> BlockT m ()
guardMempool forall a b. (a -> b) -> a -> b
$ do
  Bool
s <- forall (m :: * -> *). MonadLoggerIO m => BlockT m Bool
isInSync
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
s forall a b. (a -> b) -> a -> b
$ do
    $(logDebugS) Text
"BlockStore" forall a b. (a -> b) -> a -> b
$
      Text
"Received inventory with "
        forall a. Semigroup a => a -> a -> a
<> forall a b. ConvertibleStrings a b => a -> b
cs (forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [TxHash]
hs))
        forall a. Semigroup a => a -> a -> a
<> Text
" transactions from peer: "
        forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
    [TxHash]
xs <- forall a. [Maybe a] -> [a]
catMaybes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {b}.
(Int -> TxHash -> ReaderT BlockStore m b)
-> ReaderT BlockStore m [b]
zip_counter forall {m :: * -> *} {a}.
(MonadIO m, MonadLogger m, Show a) =>
a -> TxHash -> ReaderT BlockStore m (Maybe TxHash)
process_tx
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TxHash]
xs) forall a b. (a -> b) -> a -> b
$ forall {m :: * -> *}.
MonadIO m =>
[TxHash] -> ReaderT BlockStore m ()
go [TxHash]
xs
  where
    len :: Int
len = 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 = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall a b. [a] -> [b] -> [(a, b)]
zip [(Int
1 :: Int) ..] [TxHash]
hs) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 =
      forall (m :: * -> *). MonadIO m => TxHash -> BlockT m Bool
isPending TxHash
h forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Bool
True -> do
          $(logDebugS) Text
"BlockStore" forall a b. (a -> b) -> a -> b
$
            Text
"Tx "
              forall a. Semigroup a => a -> a -> a
<> forall a b. ConvertibleStrings a b => a -> b
cs (forall a. Show a => a -> String
show a
i)
              forall a. Semigroup a => a -> a -> a
<> Text
"/"
              forall a. Semigroup a => a -> a -> a
<> forall a b. ConvertibleStrings a b => a -> b
cs (forall a. Show a => a -> String
show Int
len)
              forall a. Semigroup a => a -> a -> a
<> Text
" "
              forall a. Semigroup a => a -> a -> a
<> TxHash -> Text
txHashToHex TxHash
h
              forall a. Semigroup a => a -> a -> a
<> Text
": "
              forall a. Semigroup a => a -> a -> a
<> Text
"Pending"
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        Bool
False ->
          forall (m :: * -> *). StoreReadBase m => TxHash -> m (Maybe TxData)
getActiveTxData TxHash
h forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just TxData
_ -> do
              $(logDebugS) Text
"BlockStore" forall a b. (a -> b) -> a -> b
$
                Text
"Tx "
                  forall a. Semigroup a => a -> a -> a
<> forall a b. ConvertibleStrings a b => a -> b
cs (forall a. Show a => a -> String
show a
i)
                  forall a. Semigroup a => a -> a -> a
<> Text
"/"
                  forall a. Semigroup a => a -> a -> a
<> forall a b. ConvertibleStrings a b => a -> b
cs (forall a. Show a => a -> String
show Int
len)
                  forall a. Semigroup a => a -> a -> a
<> Text
" "
                  forall a. Semigroup a => a -> a -> a
<> TxHash -> Text
txHashToHex TxHash
h
                  forall a. Semigroup a => a -> a -> a
<> Text
": "
                  forall a. Semigroup a => a -> a -> a
<> Text
"Already Imported"
              forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
            Maybe TxData
Nothing -> do
              $(logDebugS) Text
"BlockStore" forall a b. (a -> b) -> a -> b
$
                Text
"Tx "
                  forall a. Semigroup a => a -> a -> a
<> forall a b. ConvertibleStrings a b => a -> b
cs (forall a. Show a => a -> String
show a
i)
                  forall a. Semigroup a => a -> a -> a
<> Text
"/"
                  forall a. Semigroup a => a -> a -> a
<> forall a b. ConvertibleStrings a b => a -> b
cs (forall a. Show a => a -> String
show Int
len)
                  forall a. Semigroup a => a -> a -> a
<> Text
" "
                  forall a. Semigroup a => a -> a -> a
<> TxHash -> Text
txHashToHex TxHash
h
                  forall a. Semigroup a => a -> a -> a
<> Text
": "
                  forall a. Semigroup a => a -> a -> a
<> Text
"Requesting"
              forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just TxHash
h)
    go :: [TxHash] -> ReaderT BlockStore m ()
go [TxHash]
xs = do
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). MonadIO m => TxHash -> BlockT m ()
addRequestedTx [TxHash]
xs
      Network
net <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (BlockStoreConfig -> Network
blockConfNet forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockStore -> BlockStoreConfig
myConfig)
      let inv :: InvType
inv = if Network -> Bool
getSegWit Network
net then InvType
InvWitnessTx else InvType
InvTx
          vec :: [InvVector]
vec = forall a b. (a -> b) -> [a] -> [b]
map (InvType -> Hash256 -> InvVector
InvVector InvType
inv forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxHash -> Hash256
getTxHash) [TxHash]
xs
          msg :: Message
msg = GetData -> Message
MGetData ([InvVector] -> GetData
GetData [InvVector]
vec)
      Message
msg 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 =
  forall (m :: * -> *).
(MonadIO m, MonadReader BlockStore m) =>
m (Maybe Syncing)
getSyncingState forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe Syncing
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just Syncing
_ -> do
      TVar (Maybe Syncing)
box <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> TVar (Maybe Syncing)
myPeer
      UTCTime
now <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
      forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$
        forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Maybe Syncing)
box forall a b. (a -> b) -> a -> b
$
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a -> b) -> a -> b
$
            \Syncing
x -> Syncing
x {syncingTime :: UTCTime
syncingTime = UTCTime
now}

checkTime :: MonadLoggerIO m => BlockT m ()
checkTime :: forall (m :: * -> *). MonadLoggerIO m => BlockT m ()
checkTime =
  forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> TVar (Maybe Syncing)
myPeer forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe Syncing
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just
      Syncing
        { syncingTime :: Syncing -> UTCTime
syncingTime = UTCTime
t,
          syncingPeer :: Syncing -> Peer
syncingPeer = Peer
p
        } -> do
        UTCTime
now <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
        NominalDiffTime
peer_time_out <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (BlockStoreConfig -> NominalDiffTime
blockConfPeerTimeout forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockStore -> BlockStoreConfig
myConfig)
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (UTCTime
now UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` UTCTime
t forall a. Ord a => a -> a -> Bool
> NominalDiffTime
peer_time_out) forall a b. (a -> b) -> a -> b
$ do
          $(logErrorS) Text
"BlockStore" forall a b. (a -> b) -> a -> b
$
            Text
"Syncing peer timeout: " forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
          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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockNode -> BlockHeader
nodeHeader forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadLoggerIO m => BlockT m BlockNode
getBest
  Chain
ch <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (BlockStoreConfig -> Chain
blockConfChain forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockStore -> BlockStoreConfig
myConfig)
  forall (m :: * -> *). MonadIO m => BlockHash -> Chain -> m Bool
chainBlockMain BlockHash
h Chain
ch forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
x -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
x forall a b. (a -> b) -> a -> b
$ do
    $(logWarnS) Text
"BlockStore" forall a b. (a -> b) -> a -> b
$
      Text
"Reverting best block: "
        forall a. Semigroup a => a -> a -> a
<> BlockHash -> Text
blockHashToHex BlockHash
h
    forall (m :: * -> *) a.
MonadLoggerIO m =>
WriterT (ExceptT ImportException m) a
-> BlockT m (Either ImportException a)
runImport (forall (m :: * -> *). MonadImport m => BlockHash -> m ()
revertBlock BlockHash
h) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left ImportException
e -> do
        $(logErrorS) Text
"BlockStore" forall a b. (a -> b) -> a -> b
$
          Text
"Could not revert block "
            forall a. Semigroup a => a -> a -> a
<> BlockHash -> Text
blockHashToHex BlockHash
h
            forall a. Semigroup a => a -> a -> a
<> Text
": "
            forall a. Semigroup a => a -> a -> a
<> forall a b. ConvertibleStrings a b => a -> b
cs (forall a. Show a => a -> String
show ImportException
e)
        forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO ImportException
e
      Right () -> forall (m :: * -> *).
(MonadReader BlockStore m, MonadIO m) =>
[BlockHash] -> m ()
setSyncingBlocks []
    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 <-
    forall (m :: * -> *). StoreReadBase m => m (Maybe BlockHash)
getBestBlock forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just BlockHash
b -> forall (m :: * -> *) a. Monad m => a -> m a
return BlockHash
b
      Maybe BlockHash
Nothing -> do
        $(logErrorS) Text
"BlockStore" Text
"No best block set"
        forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO BlockException
Uninitialized
  Chain
ch <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (BlockStoreConfig -> Chain
blockConfChain forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockStore -> BlockStoreConfig
myConfig)
  forall (m :: * -> *).
MonadIO m =>
BlockHash -> Chain -> m (Maybe BlockNode)
chainGetBlock BlockHash
bb Chain
ch forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just BlockNode
x -> forall (m :: * -> *) a. Monad m => a -> m a
return BlockNode
x
    Maybe BlockNode
Nothing -> do
      $(logErrorS) Text
"BlockStore" forall a b. (a -> b) -> a -> b
$
        Text
"Header not found for best block: "
          forall a. Semigroup a => a -> a -> a
<> BlockHash -> Text
blockHashToHex BlockHash
bb
      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 <-
    forall (m :: * -> *).
(MonadReader BlockStore m, MonadIO m) =>
m [BlockHash]
getSyncingBlocks forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      [] ->
        forall (m :: * -> *). StoreReadBase m => m (Maybe BlockHash)
getBestBlock forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Just BlockHash
b -> forall (m :: * -> *) a. Monad m => a -> m a
return BlockHash
b
          Maybe BlockHash
Nothing -> do
            $(logErrorS) Text
"BlockStore" Text
"No best block set"
            forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO BlockException
Uninitialized
      [BlockHash]
hs -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
last [BlockHash]
hs
  Chain
ch <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (BlockStoreConfig -> Chain
blockConfChain forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockStore -> BlockStoreConfig
myConfig)
  forall (m :: * -> *).
MonadIO m =>
BlockHash -> Chain -> m (Maybe BlockNode)
chainGetBlock BlockHash
bb Chain
ch forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just BlockNode
x -> forall (m :: * -> *) a. Monad m => a -> m a
return BlockNode
x
    Maybe BlockNode
Nothing -> do
      $(logErrorS) Text
"BlockStore" forall a b. (a -> b) -> a -> b
$
        Text
"Header not found for block: "
          forall a. Semigroup a => a -> a -> a
<> BlockHash -> Text
blockHashToHex BlockHash
bb
      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 =
  forall (m :: * -> *). MonadLoggerIO m => BlockT m Bool
isInSync forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Bool
True -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    Bool
False ->
      forall (m :: * -> *).
(MonadIO m, MonadReader BlockStore m) =>
m (Maybe Syncing)
getSyncingState forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe Syncing
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        Just Syncing {syncingPeer :: Syncing -> Peer
syncingPeer = Peer
p, syncingBlocks :: Syncing -> [BlockHash]
syncingBlocks = [BlockHash]
bs}
          | Int
100 forall a. Ord a => a -> a -> Bool
> forall (t :: * -> *) a. Foldable t => t a -> Int
length [BlockHash]
bs -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just Peer
p)
          | Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

syncMe :: MonadLoggerIO m => BlockT m ()
syncMe :: forall (m :: * -> *). MonadLoggerIO m => BlockT m ()
syncMe = do
  forall (m :: * -> *). MonadLoggerIO m => BlockT m ()
revertToMainChain
  forall (m :: * -> *). MonadLoggerIO m => BlockT m (Maybe Peer)
shouldSync forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe Peer
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just Peer
p -> do
      BlockNode
bb <- forall (m :: * -> *). MonadLoggerIO m => BlockT m BlockNode
getSyncBest
      BlockNode
bh <- ReaderT BlockStore m BlockNode
getbh
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BlockNode
bb forall a. Eq a => a -> a -> Bool
/= BlockNode
bh) forall a b. (a -> b) -> a -> b
$ do
        [BlockNode]
bns <- forall {m :: * -> *}.
(MonadLoggerIO m, MonadReader BlockStore m) =>
BlockNode -> BlockNode -> m [BlockNode]
sel BlockNode
bb BlockNode
bh
        [InvVector]
iv <- forall {m :: * -> *}.
MonadReader BlockStore m =>
[BlockNode] -> m [InvVector]
getiv [BlockNode]
bns
        $(logDebugS) Text
"BlockStore" forall a b. (a -> b) -> a -> b
$
          Text
"Requesting "
            forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => String -> a
fromString (forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [InvVector]
iv))
            forall a. Semigroup a => a -> a -> a
<> Text
" blocks from peer: "
            forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
        forall (m :: * -> *).
(MonadReader BlockStore m, MonadIO m) =>
[BlockHash] -> m ()
addSyncingBlocks forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (BlockHeader -> BlockHash
headerHash forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockNode -> BlockHeader
nodeHeader) [BlockNode]
bns
        GetData -> Message
MGetData ([InvVector] -> GetData
GetData [InvVector]
iv) forall (m :: * -> *). MonadIO m => Message -> Peer -> m ()
`sendMessage` Peer
p
  where
    getiv :: [BlockNode] -> m [InvVector]
getiv [BlockNode]
bns = do
      Bool
w <- Network -> Bool
getSegWit forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (BlockStoreConfig -> Network
blockConfNet forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockStore -> BlockStoreConfig
myConfig)
      let i :: InvType
i = if Bool
w then InvType
InvWitnessBlock else InvType
InvBlock
          f :: BlockNode -> InvVector
f = InvType -> Hash256 -> InvVector
InvVector InvType
i forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockHash -> Hash256
getBlockHash forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockHeader -> BlockHash
headerHash forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockNode -> BlockHeader
nodeHeader
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map BlockNode -> InvVector
f [BlockNode]
bns
    getbh :: ReaderT BlockStore m BlockNode
getbh =
      forall (m :: * -> *). MonadIO m => Chain -> m BlockNode
chainGetBest forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (BlockStoreConfig -> Chain
blockConfChain forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockStore -> BlockStoreConfig
myConfig)
    sel :: BlockNode -> BlockNode -> m [BlockNode]
sel BlockNode
bb BlockNode
bh = do
      let sh :: BlockHeight
sh = BlockNode -> BlockNode -> BlockHeight
geth BlockNode
bb BlockNode
bh
      BlockNode
t <- forall {m :: * -> *}.
(MonadLoggerIO m, MonadReader BlockStore m) =>
BlockHeight -> BlockNode -> m BlockNode
top BlockHeight
sh BlockNode
bh
      Chain
ch <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (BlockStoreConfig -> Chain
blockConfChain forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockStore -> BlockStoreConfig
myConfig)
      [BlockNode]
ps <- forall (m :: * -> *).
MonadIO m =>
BlockHeight -> BlockNode -> Chain -> m [BlockNode]
chainGetParents (BlockNode -> BlockHeight
nodeHeight BlockNode
bb forall a. Num a => a -> a -> a
+ BlockHeight
1) BlockNode
t Chain
ch
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
        if Int
500 forall a. Ord a => a -> a -> Bool
> forall (t :: * -> *) a. Foldable t => t a -> Int
length [BlockNode]
ps
          then [BlockNode]
ps forall a. Semigroup a => a -> a -> a
<> [BlockNode
bh]
          else [BlockNode]
ps
    geth :: BlockNode -> BlockNode -> BlockHeight
geth BlockNode
bb BlockNode
bh =
      forall a. Ord a => a -> a -> a
min
        (BlockNode -> BlockHeight
nodeHeight BlockNode
bb forall a. Num a => a -> a -> a
+ BlockHeight
501)
        (BlockNode -> BlockHeight
nodeHeight BlockNode
bh)
    top :: BlockHeight -> BlockNode -> m BlockNode
top BlockHeight
sh BlockNode
bh =
      if BlockHeight
sh forall a. Eq a => a -> a -> Bool
== BlockNode -> BlockHeight
nodeHeight BlockNode
bh
        then forall (m :: * -> *) a. Monad m => a -> m a
return BlockNode
bh
        else 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 <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (BlockStoreConfig -> Chain
blockConfChain forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockStore -> BlockStoreConfig
myConfig)
  forall (m :: * -> *).
MonadIO m =>
BlockHeight -> BlockNode -> Chain -> m (Maybe BlockNode)
chainGetAncestor BlockHeight
height BlockNode
target Chain
ch forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just BlockNode
ancestor -> forall (m :: * -> *) a. Monad m => a -> m a
return BlockNode
ancestor
    Maybe BlockNode
Nothing -> do
      let h :: BlockHash
h = BlockHeader -> BlockHash
headerHash forall a b. (a -> b) -> a -> b
$ BlockNode -> BlockHeader
nodeHeader BlockNode
target
      $(logErrorS) Text
"BlockStore" forall a b. (a -> b) -> a -> b
$
        Text
"Could not find header for ancestor of block "
          forall a. Semigroup a => a -> a -> a
<> BlockHash -> Text
blockHashToHex BlockHash
h
          forall a. Semigroup a => a -> a -> a
<> Text
" at height "
          forall a. Semigroup a => a -> a -> a
<> forall a b. ConvertibleStrings a b => a -> b
cs (forall a. Show a => a -> String
show (BlockNode -> BlockHeight
nodeHeight BlockNode
target))
      forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO 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 <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> TVar (Maybe Syncing)
myPeer
  forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar (Maybe Syncing)
box forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just Syncing {syncingPeer :: Syncing -> Peer
syncingPeer = Peer
p'} | Peer
p forall a. Eq a => a -> a -> Bool
== Peer
p' -> forall {m :: * -> *} {a}.
(MonadIO m, MonadLogger m) =>
TVar (Maybe a) -> m ()
reset_it TVar (Maybe Syncing)
box
    Maybe Syncing
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    reset_it :: TVar (Maybe a) -> m ()
reset_it TVar (Maybe a)
box = do
      forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe a)
box forall a. Maybe a
Nothing
      $(logDebugS) Text
"BlockStore" forall a b. (a -> b) -> a -> b
$ Text
"Releasing peer: " forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
      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 =
  forall (m :: * -> *).
(MonadIO m, MonadReader BlockStore m) =>
m (Maybe Syncing)
getSyncingState forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just Syncing
_ -> 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 =
      forall (m :: * -> *). MonadIO m => Peer -> m Bool
setBusy Peer
p forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Bool
False -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Bool
True -> do
          $(logDebugS) Text
"BlockStore" forall a b. (a -> b) -> a -> b
$
            Text
"Locked peer: " forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
          TVar (Maybe Syncing)
box <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> TVar (Maybe Syncing)
myPeer
          UTCTime
now <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
          forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe Syncing)
box forall a b. (a -> b) -> a -> b
$
            forall a. a -> Maybe a
Just
              Syncing
                { syncingPeer :: Peer
syncingPeer = Peer
p,
                  syncingTime :: UTCTime
syncingTime = UTCTime
now,
                  syncingBlocks :: [BlockHash]
syncingBlocks = []
                }
          forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

trySyncing :: MonadLoggerIO m => BlockT m ()
trySyncing :: forall (m :: * -> *). MonadLoggerIO m => BlockT m ()
trySyncing =
  forall (m :: * -> *). MonadLoggerIO m => BlockT m Bool
isInSync forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Bool
True -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Bool
False ->
      forall (m :: * -> *).
(MonadIO m, MonadReader BlockStore m) =>
m (Maybe Syncing)
getSyncingState forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just Syncing
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Maybe Syncing
Nothing -> ReaderT BlockStore m ()
online_peer
  where
    recurse :: [Peer] -> ReaderT BlockStore m ()
recurse [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    recurse (Peer
p : [Peer]
ps) =
      forall (m :: * -> *). MonadLoggerIO m => Peer -> BlockT m Bool
trySetPeer Peer
p 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 -> forall (m :: * -> *). MonadLoggerIO m => BlockT m ()
syncMe
    online_peer :: ReaderT BlockStore m ()
online_peer = do
      [OnlinePeer]
ops <- forall (m :: * -> *). MonadIO m => PeerManager -> m [OnlinePeer]
getPeers forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (BlockStoreConfig -> PeerManager
blockConfManager forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockStore -> BlockStoreConfig
myConfig)
      let ps :: [Peer]
ps = forall a b. (a -> b) -> [a] -> [b]
map OnlinePeer -> Peer
onlinePeerMailbox [OnlinePeer]
ops
      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 =
  forall (m :: * -> *). MonadLoggerIO m => BlockT m Bool
isInSync forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Bool
True -> forall (m :: * -> *).
(MonadUnliftIO m, MonadLoggerIO m) =>
Peer -> BlockT m ()
mempool Peer
p
    Bool
False ->
      forall (m :: * -> *). MonadLoggerIO m => Peer -> BlockT m Bool
trySetPeer Peer
p forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Bool
False -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Bool
True -> 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 =
  forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> TVar (Maybe Syncing)
myPeer

clearSyncingState ::
  (MonadLoggerIO m, MonadReader BlockStore m) => m ()
clearSyncingState :: forall (m :: * -> *).
(MonadLoggerIO m, MonadReader BlockStore m) =>
m ()
clearSyncingState =
  forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> TVar (Maybe Syncing)
myPeer forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe Syncing
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just Syncing {syncingPeer :: Syncing -> Peer
syncingPeer = Peer
p} -> 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
_) =
  forall (m :: * -> *). MonadLoggerIO m => BlockT m ()
trySyncing
processBlockStoreMessage (BlockPeerConnect Peer
p) =
  forall (m :: * -> *).
(MonadUnliftIO m, MonadLoggerIO m) =>
Peer -> BlockT m ()
trySyncingPeer Peer
p
processBlockStoreMessage (BlockPeerDisconnect Peer
p) =
  forall (m :: * -> *).
(MonadLoggerIO m, MonadReader BlockStore m) =>
Peer -> m ()
finishPeer Peer
p
processBlockStoreMessage (BlockReceived Peer
p Block
b) =
  forall (m :: * -> *).
(MonadUnliftIO m, MonadLoggerIO m) =>
Peer -> Block -> BlockT m ()
processBlock Peer
p Block
b
processBlockStoreMessage (BlockNotFound Peer
p [BlockHash]
bs) =
  forall (m :: * -> *).
MonadLoggerIO m =>
Peer -> [BlockHash] -> BlockT m ()
processNoBlocks Peer
p [BlockHash]
bs
processBlockStoreMessage (TxRefReceived Peer
p Tx
tx) =
  forall (m :: * -> *). MonadLoggerIO m => Peer -> Tx -> BlockT m ()
processTx Peer
p Tx
tx
processBlockStoreMessage (TxRefAvailable Peer
p [TxHash]
ts) =
  forall (m :: * -> *).
MonadLoggerIO m =>
Peer -> [TxHash] -> BlockT m ()
processTxs Peer
p [TxHash]
ts
processBlockStoreMessage (BlockPing Listen ()
r) = do
  forall (m :: * -> *). MonadIO m => BlockT m ()
setStoreHeight
  forall (m :: * -> *). MonadIO m => BlockT m ()
setHeadersHeight
  forall (m :: * -> *). MonadIO m => BlockT m ()
setPendingTxs
  forall (m :: * -> *). MonadIO m => BlockT m ()
setPeersConnected
  forall (m :: * -> *). MonadIO m => BlockT m ()
setMempoolSize
  forall (m :: * -> *). MonadLoggerIO m => BlockT m ()
trySyncing
  forall (m :: * -> *). MonadLoggerIO m => BlockT m ()
processMempool
  forall (m :: * -> *). MonadIO m => BlockT m ()
pruneOrphans
  forall (m :: * -> *). MonadLoggerIO m => BlockT m ()
checkTime
  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 =
  forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
    Listen () -> BlockStoreMessage
BlockPing forall (m :: * -> *) (mbox :: * -> *) response request.
(MonadIO m, OutChan mbox) =>
(Listen response -> request) -> mbox request -> m response
`query` Mailbox BlockStoreMessage
mbox
    Int
delay <-
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
        forall a (m :: * -> *). (Random a, MonadIO m) => (a, a) -> m a
randomRIO
          ( Int
100 forall a. Num a => a -> a -> a
* Int
1000,
            Int
1000 forall a. Num a => a -> a -> a
* Int
1000
          )
    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 forall (m :: * -> *) (mbox :: * -> *) msg.
(MonadIO m, OutChan mbox) =>
msg -> mbox msg -> m ()
`send` BlockStore -> Mailbox BlockStoreMessage
myMailbox BlockStore
store

blockStorePeerDisconnect ::
  MonadIO m => Peer -> BlockStore -> m ()
blockStorePeerDisconnect :: forall (m :: * -> *). MonadIO m => Peer -> BlockStore -> m ()
blockStorePeerDisconnect Peer
peer BlockStore
store =
  Peer -> BlockStoreMessage
BlockPeerDisconnect Peer
peer forall (m :: * -> *) (mbox :: * -> *) msg.
(MonadIO m, OutChan mbox) =>
msg -> mbox msg -> m ()
`send` BlockStore -> Mailbox BlockStoreMessage
myMailbox BlockStore
store

blockStoreHead ::
  MonadIO m => BlockNode -> BlockStore -> m ()
blockStoreHead :: forall (m :: * -> *). MonadIO m => BlockNode -> BlockStore -> m ()
blockStoreHead BlockNode
node BlockStore
store =
  BlockNode -> BlockStoreMessage
BlockNewBest BlockNode
node forall (m :: * -> *) (mbox :: * -> *) msg.
(MonadIO m, OutChan mbox) =>
msg -> mbox msg -> m ()
`send` BlockStore -> Mailbox BlockStoreMessage
myMailbox BlockStore
store

blockStoreBlock ::
  MonadIO m => Peer -> Block -> BlockStore -> m ()
blockStoreBlock :: forall (m :: * -> *).
MonadIO m =>
Peer -> Block -> BlockStore -> m ()
blockStoreBlock Peer
peer Block
block BlockStore
store =
  Peer -> Block -> BlockStoreMessage
BlockReceived Peer
peer Block
block forall (m :: * -> *) (mbox :: * -> *) msg.
(MonadIO m, OutChan mbox) =>
msg -> mbox msg -> m ()
`send` BlockStore -> Mailbox BlockStoreMessage
myMailbox BlockStore
store

blockStoreNotFound ::
  MonadIO m => Peer -> [BlockHash] -> BlockStore -> m ()
blockStoreNotFound :: forall (m :: * -> *).
MonadIO m =>
Peer -> [BlockHash] -> BlockStore -> m ()
blockStoreNotFound Peer
peer [BlockHash]
blocks BlockStore
store =
  Peer -> [BlockHash] -> BlockStoreMessage
BlockNotFound Peer
peer [BlockHash]
blocks forall (m :: * -> *) (mbox :: * -> *) msg.
(MonadIO m, OutChan mbox) =>
msg -> mbox msg -> m ()
`send` BlockStore -> Mailbox BlockStoreMessage
myMailbox BlockStore
store

blockStoreTx ::
  MonadIO m => Peer -> Tx -> BlockStore -> m ()
blockStoreTx :: forall (m :: * -> *). MonadIO m => Peer -> Tx -> BlockStore -> m ()
blockStoreTx Peer
peer Tx
tx BlockStore
store =
  Peer -> Tx -> BlockStoreMessage
TxRefReceived Peer
peer Tx
tx forall (m :: * -> *) (mbox :: * -> *) msg.
(MonadIO m, OutChan mbox) =>
msg -> mbox msg -> m ()
`send` BlockStore -> Mailbox BlockStoreMessage
myMailbox BlockStore
store

blockStoreTxHash ::
  MonadIO m => Peer -> [TxHash] -> BlockStore -> m ()
blockStoreTxHash :: forall (m :: * -> *).
MonadIO m =>
Peer -> [TxHash] -> BlockStore -> m ()
blockStoreTxHash Peer
peer [TxHash]
txhashes BlockStore
store =
  Peer -> [TxHash] -> BlockStoreMessage
TxRefAvailable Peer
peer [TxHash]
txhashes forall (m :: * -> *) (mbox :: * -> *) msg.
(MonadIO m, OutChan mbox) =>
msg -> mbox msg -> m ()
`send` BlockStore -> Mailbox BlockStoreMessage
myMailbox BlockStore
store

blockStorePeerConnectSTM ::
  Peer -> BlockStore -> STM ()
blockStorePeerConnectSTM :: Peer -> BlockStore -> STM ()
blockStorePeerConnectSTM Peer
peer BlockStore
store =
  Peer -> BlockStoreMessage
BlockPeerConnect Peer
peer forall (mbox :: * -> *) msg.
OutChan mbox =>
msg -> mbox msg -> STM ()
`sendSTM` BlockStore -> Mailbox BlockStoreMessage
myMailbox BlockStore
store

blockStorePeerDisconnectSTM ::
  Peer -> BlockStore -> STM ()
blockStorePeerDisconnectSTM :: Peer -> BlockStore -> STM ()
blockStorePeerDisconnectSTM Peer
peer BlockStore
store =
  Peer -> BlockStoreMessage
BlockPeerDisconnect Peer
peer forall (mbox :: * -> *) msg.
OutChan mbox =>
msg -> mbox msg -> STM ()
`sendSTM` BlockStore -> Mailbox BlockStoreMessage
myMailbox BlockStore
store

blockStoreHeadSTM ::
  BlockNode -> BlockStore -> STM ()
blockStoreHeadSTM :: BlockNode -> BlockStore -> STM ()
blockStoreHeadSTM BlockNode
node BlockStore
store =
  BlockNode -> BlockStoreMessage
BlockNewBest BlockNode
node forall (mbox :: * -> *) msg.
OutChan mbox =>
msg -> mbox msg -> STM ()
`sendSTM` BlockStore -> Mailbox BlockStoreMessage
myMailbox BlockStore
store

blockStoreBlockSTM ::
  Peer -> Block -> BlockStore -> STM ()
blockStoreBlockSTM :: Peer -> Block -> BlockStore -> STM ()
blockStoreBlockSTM Peer
peer Block
block BlockStore
store =
  Peer -> Block -> BlockStoreMessage
BlockReceived Peer
peer Block
block forall (mbox :: * -> *) msg.
OutChan mbox =>
msg -> mbox msg -> STM ()
`sendSTM` BlockStore -> Mailbox BlockStoreMessage
myMailbox BlockStore
store

blockStoreNotFoundSTM ::
  Peer -> [BlockHash] -> BlockStore -> STM ()
blockStoreNotFoundSTM :: Peer -> [BlockHash] -> BlockStore -> STM ()
blockStoreNotFoundSTM Peer
peer [BlockHash]
blocks BlockStore
store =
  Peer -> [BlockHash] -> BlockStoreMessage
BlockNotFound Peer
peer [BlockHash]
blocks forall (mbox :: * -> *) msg.
OutChan mbox =>
msg -> mbox msg -> STM ()
`sendSTM` BlockStore -> Mailbox BlockStoreMessage
myMailbox BlockStore
store

blockStoreTxSTM ::
  Peer -> Tx -> BlockStore -> STM ()
blockStoreTxSTM :: Peer -> Tx -> BlockStore -> STM ()
blockStoreTxSTM Peer
peer Tx
tx BlockStore
store =
  Peer -> Tx -> BlockStoreMessage
TxRefReceived Peer
peer Tx
tx forall (mbox :: * -> *) msg.
OutChan mbox =>
msg -> mbox msg -> STM ()
`sendSTM` BlockStore -> Mailbox BlockStoreMessage
myMailbox BlockStore
store

blockStoreTxHashSTM ::
  Peer -> [TxHash] -> BlockStore -> STM ()
blockStoreTxHashSTM :: Peer -> [TxHash] -> BlockStore -> STM ()
blockStoreTxHashSTM Peer
peer [TxHash]
txhashes BlockStore
store =
  Peer -> [TxHash] -> BlockStoreMessage
TxRefAvailable Peer
peer [TxHash]
txhashes forall (mbox :: * -> *) msg.
OutChan mbox =>
msg -> mbox msg -> STM ()
`sendSTM` BlockStore -> Mailbox BlockStoreMessage
myMailbox BlockStore
store

blockStorePendingTxs ::
  MonadIO m => BlockStore -> m Int
blockStorePendingTxs :: forall (m :: * -> *). MonadIO m => BlockStore -> m Int
blockStorePendingTxs =
  forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically 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 (HashSet TxHash)
TVar (HashMap TxHash PendingTx)
Mailbox BlockStoreMessage
BlockStoreConfig
myMetrics :: Maybe StoreMetrics
requested :: TVar (HashSet TxHash)
myTxs :: TVar (HashMap TxHash PendingTx)
myPeer :: TVar (Maybe Syncing)
myConfig :: BlockStoreConfig
myMailbox :: Mailbox BlockStoreMessage
myMetrics :: BlockStore -> Maybe StoreMetrics
requested :: BlockStore -> TVar (HashSet TxHash)
myTxs :: BlockStore -> TVar (HashMap TxHash PendingTx)
myPeer :: BlockStore -> TVar (Maybe Syncing)
myConfig :: BlockStore -> BlockStoreConfig
myMailbox :: BlockStore -> Mailbox BlockStoreMessage
..} = do
  HashSet TxHash
x <- forall k a. HashMap k a -> HashSet k
HashMap.keysSet forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TVar a -> STM a
readTVar TVar (HashMap TxHash PendingTx)
myTxs
  HashSet TxHash
y <- forall a. TVar a -> STM a
readTVar TVar (HashSet TxHash)
requested
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. HashSet a -> Int
HashSet.size forall a b. (a -> b) -> a -> b
$ HashSet TxHash
x 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 forall a. Semigroup a => a -> a -> a
<> Text
sep forall a. Semigroup a => a -> a -> a
<> Text
t forall a. Semigroup a => a -> a -> a
<> Text
sep forall a. Semigroup a => a -> a -> a
<> Text
hash
  Just Block
block ->
    Text
height forall a. Semigroup a => a -> a -> a
<> Text
sep forall a. Semigroup a => a -> a -> a
<> Text
t forall a. Semigroup a => a -> a -> a
<> Text
sep forall a. Semigroup a => a -> a -> a
<> Text
hash forall a. Semigroup a => a -> a -> a
<> Text
sep forall a. Semigroup a => a -> a -> a
<> Block -> Text
size Block
block
  where
    height :: Text
height = forall a b. ConvertibleStrings a b => a -> b
cs forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show (BlockNode -> BlockHeight
nodeHeight BlockNode
bn)
    b :: UTCTime
b = NominalDiffTime -> UTCTime
posixSecondsToUTCTime forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockHeader -> BlockHeight
blockTimestamp forall a b. (a -> b) -> a -> b
$ BlockNode -> BlockHeader
nodeHeader BlockNode
bn
    t :: Text
t = forall a b. ConvertibleStrings a b => a -> b
cs forall a b. (a -> b) -> a -> b
$ 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 -> BlockHeader
nodeHeader BlockNode
bn))
    sep :: Text
sep = Text
" | "
    size :: Block -> Text
size = (forall a. Semigroup a => a -> a -> a
<> Text
" bytes") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. ConvertibleStrings a b => a -> b
cs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int
B.length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Serialize a => a -> ByteString
encode