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

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

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

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

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

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

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

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

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

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

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

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

type BlockT m = ReaderT BlockStore m

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

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

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

instance MonadUnliftIO m => StoreReadExtra (BlockT m) where
    getMaxGap :: BlockT m BlockHeight
getMaxGap =
        ReaderT DatabaseReader m BlockHeight -> BlockT m BlockHeight
forall (m :: * -> *) a. ReaderT DatabaseReader m a -> BlockT m a
runRocksDB ReaderT DatabaseReader m BlockHeight
forall (m :: * -> *). StoreReadExtra m => m BlockHeight
getMaxGap
    getInitialGap :: BlockT m BlockHeight
getInitialGap =
        ReaderT DatabaseReader m BlockHeight -> BlockT m BlockHeight
forall (m :: * -> *) a. ReaderT DatabaseReader m a -> BlockT m a
runRocksDB ReaderT DatabaseReader m BlockHeight
forall (m :: * -> *). StoreReadExtra m => m BlockHeight
getInitialGap
    getAddressesTxs :: [Address] -> Limits -> BlockT m [TxRef]
getAddressesTxs [Address]
as =
        ReaderT DatabaseReader m [TxRef] -> BlockT m [TxRef]
forall (m :: * -> *) a. ReaderT DatabaseReader m a -> BlockT m a
runRocksDB (ReaderT DatabaseReader m [TxRef] -> BlockT m [TxRef])
-> (Limits -> ReaderT DatabaseReader m [TxRef])
-> Limits
-> BlockT m [TxRef]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Address] -> Limits -> ReaderT DatabaseReader m [TxRef]
forall (m :: * -> *).
StoreReadExtra m =>
[Address] -> Limits -> m [TxRef]
getAddressesTxs [Address]
as
    getAddressesUnspents :: [Address] -> Limits -> BlockT m [Unspent]
getAddressesUnspents [Address]
as =
        ReaderT DatabaseReader m [Unspent] -> BlockT m [Unspent]
forall (m :: * -> *) a. ReaderT DatabaseReader m a -> BlockT m a
runRocksDB (ReaderT DatabaseReader m [Unspent] -> BlockT m [Unspent])
-> (Limits -> ReaderT DatabaseReader m [Unspent])
-> Limits
-> BlockT m [Unspent]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Address] -> Limits -> ReaderT DatabaseReader m [Unspent]
forall (m :: * -> *).
StoreReadExtra m =>
[Address] -> Limits -> m [Unspent]
getAddressesUnspents [Address]
as
    getAddressUnspents :: Address -> Limits -> BlockT m [Unspent]
getAddressUnspents Address
a =
        ReaderT DatabaseReader m [Unspent] -> BlockT m [Unspent]
forall (m :: * -> *) a. ReaderT DatabaseReader m a -> BlockT m a
runRocksDB (ReaderT DatabaseReader m [Unspent] -> BlockT m [Unspent])
-> (Limits -> ReaderT DatabaseReader m [Unspent])
-> Limits
-> BlockT m [Unspent]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Address -> Limits -> ReaderT DatabaseReader m [Unspent]
forall (m :: * -> *).
StoreReadExtra m =>
Address -> Limits -> m [Unspent]
getAddressUnspents Address
a
    getAddressTxs :: Address -> Limits -> BlockT m [TxRef]
getAddressTxs Address
a =
        ReaderT DatabaseReader m [TxRef] -> BlockT m [TxRef]
forall (m :: * -> *) a. ReaderT DatabaseReader m a -> BlockT m a
runRocksDB (ReaderT DatabaseReader m [TxRef] -> BlockT m [TxRef])
-> (Limits -> ReaderT DatabaseReader m [TxRef])
-> Limits
-> BlockT m [TxRef]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Address -> Limits -> ReaderT DatabaseReader m [TxRef]
forall (m :: * -> *).
StoreReadExtra m =>
Address -> Limits -> m [TxRef]
getAddressTxs Address
a
    getNumTxData :: UnixTime -> BlockT m [TxData]
getNumTxData =
        ReaderT DatabaseReader m [TxData] -> BlockT m [TxData]
forall (m :: * -> *) a. ReaderT DatabaseReader m a -> BlockT m a
runRocksDB (ReaderT DatabaseReader m [TxData] -> BlockT m [TxData])
-> (UnixTime -> ReaderT DatabaseReader m [TxData])
-> UnixTime
-> BlockT m [TxData]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnixTime -> ReaderT DatabaseReader m [TxData]
forall (m :: * -> *). StoreReadExtra m => UnixTime -> m [TxData]
getNumTxData

-- | Run block store process.
withBlockStore ::
       (MonadUnliftIO m, MonadLoggerIO m)
    => BlockStoreConfig
    -> (BlockStore -> m a)
    -> m a
withBlockStore :: BlockStoreConfig -> (BlockStore -> m a) -> m a
withBlockStore BlockStoreConfig
cfg BlockStore -> m a
action = do
    TVar (Maybe Syncing)
pb <- Maybe Syncing -> m (TVar (Maybe Syncing))
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Maybe Syncing
forall a. Maybe a
Nothing
    TVar (HashMap TxHash PendingTx)
ts <- HashMap TxHash PendingTx -> m (TVar (HashMap TxHash PendingTx))
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO HashMap TxHash PendingTx
forall k v. HashMap k v
HashMap.empty
    TVar (HashSet TxHash)
rq <- HashSet TxHash -> m (TVar (HashSet TxHash))
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO HashSet TxHash
forall a. HashSet a
HashSet.empty
    Inbox BlockStoreMessage
inbox <- m (Inbox BlockStoreMessage)
forall (m :: * -> *) msg. MonadIO m => m (Inbox msg)
newInbox
    Maybe StoreMetrics
metrics <- (Store -> m StoreMetrics) -> Maybe Store -> m (Maybe StoreMetrics)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Store -> m StoreMetrics
forall (m :: * -> *). MonadIO m => Store -> m StoreMetrics
newStoreMetrics (BlockStoreConfig -> Maybe Store
blockConfStats BlockStoreConfig
cfg)
    let r :: BlockStore
r = BlockStore :: Mailbox BlockStoreMessage
-> BlockStoreConfig
-> TVar (Maybe Syncing)
-> TVar (HashMap TxHash PendingTx)
-> TVar (HashSet TxHash)
-> Maybe StoreMetrics
-> BlockStore
BlockStore { myMailbox :: Mailbox BlockStoreMessage
myMailbox = Inbox BlockStoreMessage -> Mailbox BlockStoreMessage
forall msg. Inbox msg -> Mailbox msg
inboxToMailbox Inbox BlockStoreMessage
inbox
                       , myConfig :: BlockStoreConfig
myConfig = BlockStoreConfig
cfg
                       , myPeer :: TVar (Maybe Syncing)
myPeer = TVar (Maybe Syncing)
pb
                       , myTxs :: TVar (HashMap TxHash PendingTx)
myTxs = TVar (HashMap TxHash PendingTx)
ts
                       , requested :: TVar (HashSet TxHash)
requested = TVar (HashSet TxHash)
rq
                       , myMetrics :: Maybe StoreMetrics
myMetrics = Maybe StoreMetrics
metrics
                       }
    m Any -> (Async Any -> m a) -> m a
forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> (Async a -> m b) -> m b
withAsync (ReaderT BlockStore m Any -> BlockStore -> m Any
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Inbox BlockStoreMessage -> ReaderT BlockStore m Any
forall b. Inbox BlockStoreMessage -> ReaderT BlockStore m b
go Inbox BlockStoreMessage
inbox) BlockStore
r) ((Async Any -> m a) -> m a) -> (Async Any -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \Async Any
a -> do
        Async Any -> m ()
forall (m :: * -> *) a. MonadIO m => Async a -> m ()
link Async Any
a
        BlockStore -> m a
action BlockStore
r
  where
    go :: Inbox BlockStoreMessage -> ReaderT BlockStore m b
go Inbox BlockStoreMessage
inbox = do
        ReaderT BlockStore m ()
ini
        ReaderT BlockStore m ()
wipe
        Inbox BlockStoreMessage -> ReaderT BlockStore m b
forall (m :: * -> *) b.
(MonadUnliftIO m, MonadLoggerIO m) =>
Inbox BlockStoreMessage -> ReaderT BlockStore m b
run Inbox BlockStoreMessage
inbox
    del :: t (a, TxHash) -> m ()
del t (a, TxHash)
txs = do
        $(Text -> Text -> m ()
logInfoS) Text
"BlockStore" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
            Text
"Deleting " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (Int -> String
forall a. Show a => a -> String
show (t (a, TxHash) -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t (a, TxHash)
txs)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" transactions"
        t (a, TxHash) -> ((a, TxHash) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ t (a, TxHash)
txs (((a, TxHash) -> m ()) -> m ()) -> ((a, TxHash) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(a
_, TxHash
th) -> Bool -> TxHash -> m ()
forall (m :: * -> *). MonadImport m => Bool -> TxHash -> m ()
deleteUnconfirmedTx Bool
False TxHash
th
    wipe_it :: [(a, TxHash)] -> ReaderT BlockStore m ()
wipe_it [(a, TxHash)]
txs = do
        let ([(a, TxHash)]
txs1, [(a, TxHash)]
txs2) = Int -> [(a, TxHash)] -> ([(a, TxHash)], [(a, TxHash)])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
1000 [(a, TxHash)]
txs
        Bool -> ReaderT BlockStore m () -> ReaderT BlockStore m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(a, TxHash)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(a, TxHash)]
txs1) (ReaderT BlockStore m () -> ReaderT BlockStore m ())
-> ReaderT BlockStore m () -> ReaderT BlockStore m ()
forall a b. (a -> b) -> a -> b
$
            WriterT (ExceptT ImportException m) ()
-> BlockT m (Either ImportException ())
forall (m :: * -> *) a.
MonadLoggerIO m =>
WriterT (ExceptT ImportException m) a
-> BlockT m (Either ImportException a)
runImport ([(a, TxHash)] -> WriterT (ExceptT ImportException m) ()
forall (m :: * -> *) (t :: * -> *) a.
(Foldable t, MonadError ImportException m, MonadLoggerIO m,
 StoreReadBase m, StoreWrite m) =>
t (a, TxHash) -> m ()
del [(a, TxHash)]
txs1) BlockT m (Either ImportException ())
-> (Either ImportException () -> ReaderT BlockStore m ())
-> ReaderT BlockStore m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Left ImportException
e -> do
                    $(Text -> Text -> ReaderT BlockStore m ()
logErrorS) Text
"BlockStore" (Text -> ReaderT BlockStore m ())
-> Text -> ReaderT BlockStore m ()
forall a b. (a -> b) -> a -> b
$
                        Text
"Could not wipe mempool: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (ImportException -> String
forall a. Show a => a -> String
show ImportException
e)
                    ImportException -> ReaderT BlockStore m ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO ImportException
e
                Right () -> [(a, TxHash)] -> ReaderT BlockStore m ()
wipe_it [(a, TxHash)]
txs2
    wipe :: ReaderT BlockStore m ()
wipe
        | BlockStoreConfig -> Bool
blockConfWipeMempool BlockStoreConfig
cfg =
              ReaderT BlockStore m [(UnixTime, TxHash)]
forall (m :: * -> *). StoreReadBase m => m [(UnixTime, TxHash)]
getMempool ReaderT BlockStore m [(UnixTime, TxHash)]
-> ([(UnixTime, TxHash)] -> ReaderT BlockStore m ())
-> ReaderT BlockStore m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [(UnixTime, TxHash)] -> ReaderT BlockStore m ()
forall (m :: * -> *) a.
MonadLoggerIO m =>
[(a, TxHash)] -> ReaderT BlockStore m ()
wipe_it
        | Bool
otherwise =
              () -> ReaderT BlockStore m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    ini :: ReaderT BlockStore m ()
ini = WriterT (ExceptT ImportException m) ()
-> BlockT m (Either ImportException ())
forall (m :: * -> *) a.
MonadLoggerIO m =>
WriterT (ExceptT ImportException m) a
-> BlockT m (Either ImportException a)
runImport WriterT (ExceptT ImportException m) ()
forall (m :: * -> *). MonadImport m => m ()
initBest BlockT m (Either ImportException ())
-> (Either ImportException () -> ReaderT BlockStore m ())
-> ReaderT BlockStore m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              Left ImportException
e -> do
                  $(Text -> Text -> ReaderT BlockStore m ()
logErrorS) Text
"BlockStore" (Text -> ReaderT BlockStore m ())
-> Text -> ReaderT BlockStore m ()
forall a b. (a -> b) -> a -> b
$
                      Text
"Could not initialize: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (ImportException -> String
forall a. Show a => a -> String
show ImportException
e)
                  ImportException -> ReaderT BlockStore m ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO ImportException
e
              Right () -> () -> ReaderT BlockStore m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    run :: Inbox BlockStoreMessage -> ReaderT BlockStore m b
run Inbox BlockStoreMessage
inbox =
          ReaderT BlockStore m ()
-> (Async () -> ReaderT BlockStore m b) -> ReaderT BlockStore m b
forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> (Async a -> m b) -> m b
withAsync (Mailbox BlockStoreMessage -> ReaderT BlockStore m ()
forall (m :: * -> *).
MonadLoggerIO m =>
Mailbox BlockStoreMessage -> m ()
pingMe (Inbox BlockStoreMessage -> Mailbox BlockStoreMessage
forall msg. Inbox msg -> Mailbox msg
inboxToMailbox Inbox BlockStoreMessage
inbox))
          ((Async () -> ReaderT BlockStore m b) -> ReaderT BlockStore m b)
-> (Async () -> ReaderT BlockStore m b) -> ReaderT BlockStore m b
forall a b. (a -> b) -> a -> b
$ ReaderT BlockStore m b -> Async () -> ReaderT BlockStore m b
forall a b. a -> b -> a
const
          (ReaderT BlockStore m b -> Async () -> ReaderT BlockStore m b)
-> ReaderT BlockStore m b -> Async () -> ReaderT BlockStore m b
forall a b. (a -> b) -> a -> b
$ ReaderT BlockStore m () -> ReaderT BlockStore m b
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever
          (ReaderT BlockStore m () -> ReaderT BlockStore m b)
-> ReaderT BlockStore m () -> ReaderT BlockStore m b
forall a b. (a -> b) -> a -> b
$ Inbox BlockStoreMessage -> ReaderT BlockStore m BlockStoreMessage
forall (mbox :: * -> *) (m :: * -> *) msg.
(InChan mbox, MonadIO m) =>
mbox msg -> m msg
receive Inbox BlockStoreMessage
inbox ReaderT BlockStore m BlockStoreMessage
-> (BlockStoreMessage -> ReaderT BlockStore m ())
-> ReaderT BlockStore m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
          (BlockStore -> m ()) -> ReaderT BlockStore m ()
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((BlockStore -> m ()) -> ReaderT BlockStore m ())
-> (BlockStoreMessage -> BlockStore -> m ())
-> BlockStoreMessage
-> ReaderT BlockStore m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT BlockStore m () -> BlockStore -> m ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (ReaderT BlockStore m () -> BlockStore -> m ())
-> (BlockStoreMessage -> ReaderT BlockStore m ())
-> BlockStoreMessage
-> BlockStore
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockStoreMessage -> ReaderT BlockStore m ()
forall (m :: * -> *).
(MonadUnliftIO m, MonadLoggerIO m) =>
BlockStoreMessage -> BlockT m ()
processBlockStoreMessage

isInSync :: MonadLoggerIO m => BlockT m Bool
isInSync :: BlockT m Bool
isInSync =
    ReaderT BlockStore m (Maybe BlockHash)
forall (m :: * -> *). StoreReadBase m => m (Maybe BlockHash)
getBestBlock ReaderT BlockStore m (Maybe BlockHash)
-> (Maybe BlockHash -> BlockT m Bool) -> BlockT m Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe BlockHash
Nothing -> do
            $(Text -> Text -> ReaderT BlockStore m ()
logErrorS) Text
"BlockStore" Text
"Block database uninitialized"
            BlockException -> BlockT m Bool
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO BlockException
Uninitialized
        Just BlockHash
bb -> do
            BlockNode
cb <- (BlockStore -> Chain) -> ReaderT BlockStore m Chain
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (BlockStoreConfig -> Chain
blockConfChain (BlockStoreConfig -> Chain)
-> (BlockStore -> BlockStoreConfig) -> BlockStore -> Chain
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockStore -> BlockStoreConfig
myConfig) ReaderT BlockStore m Chain
-> (Chain -> ReaderT BlockStore m BlockNode)
-> ReaderT BlockStore m BlockNode
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Chain -> ReaderT BlockStore m BlockNode
forall (m :: * -> *). MonadIO m => Chain -> m BlockNode
chainGetBest
            if BlockHeader -> BlockHash
headerHash (BlockNode -> BlockHeader
nodeHeader BlockNode
cb) BlockHash -> BlockHash -> Bool
forall a. Eq a => a -> a -> Bool
== BlockHash
bb
                then ReaderT BlockStore m ()
forall (m :: * -> *).
(MonadLoggerIO m, MonadReader BlockStore m) =>
m ()
clearSyncingState ReaderT BlockStore m () -> BlockT m Bool -> BlockT m Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> BlockT m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                else Bool -> BlockT m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

guardMempool :: Monad m => BlockT m () -> BlockT m ()
guardMempool :: BlockT m () -> BlockT m ()
guardMempool BlockT m ()
f = do
    Bool
n <- (BlockStore -> Bool) -> ReaderT BlockStore m Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (BlockStoreConfig -> Bool
blockConfNoMempool (BlockStoreConfig -> Bool)
-> (BlockStore -> BlockStoreConfig) -> BlockStore -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockStore -> BlockStoreConfig
myConfig)
    Bool -> BlockT m () -> BlockT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
n BlockT m ()
f

syncMempool :: Monad m => BlockT m () -> BlockT m ()
syncMempool :: BlockT m () -> BlockT m ()
syncMempool BlockT m ()
f = do
    Bool
s <- (BlockStore -> Bool) -> ReaderT BlockStore m Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (BlockStoreConfig -> Bool
blockConfSyncMempool (BlockStoreConfig -> Bool)
-> (BlockStore -> BlockStoreConfig) -> BlockStore -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockStore -> BlockStoreConfig
myConfig)
    Bool -> BlockT m () -> BlockT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
s BlockT m ()
f

mempool :: (MonadUnliftIO m, MonadLoggerIO m) => Peer -> BlockT m ()
mempool :: Peer -> BlockT m ()
mempool Peer
p = BlockT m () -> BlockT m ()
forall (m :: * -> *). Monad m => BlockT m () -> BlockT m ()
guardMempool (BlockT m () -> BlockT m ()) -> BlockT m () -> BlockT m ()
forall a b. (a -> b) -> a -> b
$ BlockT m () -> BlockT m ()
forall (m :: * -> *). Monad m => BlockT m () -> BlockT m ()
syncMempool (BlockT m () -> BlockT m ()) -> BlockT m () -> BlockT m ()
forall a b. (a -> b) -> a -> b
$ ReaderT BlockStore m (Async ()) -> BlockT m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT BlockStore m (Async ()) -> BlockT m ())
-> ReaderT BlockStore m (Async ()) -> BlockT m ()
forall a b. (a -> b) -> a -> b
$ BlockT m () -> ReaderT BlockStore m (Async ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async (BlockT m () -> ReaderT BlockStore m (Async ()))
-> BlockT m () -> ReaderT BlockStore m (Async ())
forall a b. (a -> b) -> a -> b
$ do
    BlockT m Bool
forall (m :: * -> *). MonadLoggerIO m => BlockT m Bool
isInSync BlockT m Bool -> (Bool -> BlockT m ()) -> BlockT m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
s -> Bool -> BlockT m () -> BlockT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
s (BlockT m () -> BlockT m ()) -> BlockT m () -> BlockT m ()
forall a b. (a -> b) -> a -> b
$ do
        $(Text -> Text -> BlockT m ()
logDebugS) Text
"BlockStore" (Text -> BlockT m ()) -> Text -> BlockT m ()
forall a b. (a -> b) -> a -> b
$
            Text
"Requesting mempool from peer: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
        Message
MMempool Message -> Peer -> BlockT m ()
forall (m :: * -> *). MonadIO m => Message -> Peer -> m ()
`sendMessage` Peer
p

processBlock :: (MonadUnliftIO m, MonadLoggerIO m)
             => Peer -> Block -> BlockT m ()
processBlock :: Peer -> Block -> BlockT m ()
processBlock Peer
peer Block
block = ReaderT BlockStore m (Maybe ()) -> BlockT m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT BlockStore m (Maybe ()) -> BlockT m ())
-> (MaybeT (ReaderT BlockStore m) ()
    -> ReaderT BlockStore m (Maybe ()))
-> MaybeT (ReaderT BlockStore m) ()
-> BlockT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MaybeT (ReaderT BlockStore m) () -> ReaderT BlockStore m (Maybe ())
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT (ReaderT BlockStore m) () -> BlockT m ())
-> MaybeT (ReaderT BlockStore m) () -> BlockT m ()
forall a b. (a -> b) -> a -> b
$ do
    Peer -> MaybeT (ReaderT BlockStore m) Bool
forall (m :: * -> *).
(MonadLoggerIO m, MonadReader BlockStore m) =>
Peer -> m Bool
checkPeer Peer
peer MaybeT (ReaderT BlockStore m) Bool
-> (Bool -> MaybeT (ReaderT BlockStore m) ())
-> MaybeT (ReaderT BlockStore m) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Bool
True -> () -> MaybeT (ReaderT BlockStore m) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Bool
False -> do
            $(Text -> Text -> MaybeT (ReaderT BlockStore m) ()
logErrorS) Text
"BlockStore" (Text -> MaybeT (ReaderT BlockStore m) ())
-> Text -> MaybeT (ReaderT BlockStore m) ()
forall a b. (a -> b) -> a -> b
$
                Text
"Non-syncing peer " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
peer
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" sent me a block: "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> BlockHash -> Text
blockHashToHex BlockHash
blockhash
            String -> PeerException
PeerMisbehaving String
"Sent unexpected block" PeerException -> Peer -> MaybeT (ReaderT BlockStore m) ()
forall (m :: * -> *). MonadIO m => PeerException -> Peer -> m ()
`killPeer` Peer
peer
            MaybeT (ReaderT BlockStore m) ()
forall (m :: * -> *) a. MonadPlus m => m a
mzero
    BlockNode
node <- BlockHash -> MaybeT (ReaderT BlockStore m) (Maybe BlockNode)
forall (m :: * -> *).
(MonadLoggerIO m, MonadReader BlockStore m) =>
BlockHash -> m (Maybe BlockNode)
getBlockNode BlockHash
blockhash MaybeT (ReaderT BlockStore m) (Maybe BlockNode)
-> (Maybe BlockNode -> MaybeT (ReaderT BlockStore m) BlockNode)
-> MaybeT (ReaderT BlockStore m) BlockNode
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just BlockNode
b -> BlockNode -> MaybeT (ReaderT BlockStore m) BlockNode
forall (m :: * -> *) a. Monad m => a -> m a
return BlockNode
b
        Maybe BlockNode
Nothing -> do
            $(Text -> Text -> MaybeT (ReaderT BlockStore m) ()
logErrorS) Text
"BlockStore" (Text -> MaybeT (ReaderT BlockStore m) ())
-> Text -> MaybeT (ReaderT BlockStore m) ()
forall a b. (a -> b) -> a -> b
$
                Text
"Peer " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
peer
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" sent unknown block: "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> BlockHash -> Text
blockHashToHex BlockHash
blockhash
            String -> PeerException
PeerMisbehaving String
"Sent unknown block" PeerException -> Peer -> MaybeT (ReaderT BlockStore m) ()
forall (m :: * -> *). MonadIO m => PeerException -> Peer -> m ()
`killPeer` Peer
peer
            MaybeT (ReaderT BlockStore m) BlockNode
forall (m :: * -> *) a. MonadPlus m => m a
mzero
    $(Text -> Text -> MaybeT (ReaderT BlockStore m) ()
logDebugS) Text
"BlockStore" (Text -> MaybeT (ReaderT BlockStore m) ())
-> Text -> MaybeT (ReaderT BlockStore m) ()
forall a b. (a -> b) -> a -> b
$
        Text
"Processing block: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> BlockNode -> Maybe Block -> Text
blockText BlockNode
node Maybe Block
forall a. Maybe a
Nothing
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" from peer: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
peer
    BlockT m () -> MaybeT (ReaderT BlockStore m) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (BlockT m () -> MaybeT (ReaderT BlockStore m) ())
-> BlockT m () -> MaybeT (ReaderT BlockStore m) ()
forall a b. (a -> b) -> a -> b
$ WriterT (ExceptT ImportException m) ()
-> BlockT m (Either ImportException ())
forall (m :: * -> *) a.
MonadLoggerIO m =>
WriterT (ExceptT ImportException m) a
-> BlockT m (Either ImportException a)
runImport (Block -> BlockNode -> WriterT (ExceptT ImportException m) ()
forall (m :: * -> *). MonadImport m => Block -> BlockNode -> m ()
importBlock Block
block BlockNode
node) BlockT m (Either ImportException ())
-> (Either ImportException () -> BlockT m ()) -> BlockT m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left ImportException
e   -> ImportException -> BlockT m ()
forall (m :: * -> *) a.
(MonadLogger m, Show a, MonadIO m) =>
a -> m ()
failure ImportException
e
        Right () -> BlockNode -> BlockT m ()
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 -> BlockT m ()
success BlockNode
node = do
        $(Text -> Text -> BlockT m ()
logInfoS) Text
"BlockStore" (Text -> BlockT m ()) -> Text -> BlockT m ()
forall a b. (a -> b) -> a -> b
$
            Text
"Best block: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> BlockNode -> Maybe Block -> Text
blockText BlockNode
node (Block -> Maybe Block
forall a. a -> Maybe a
Just Block
block)
        BlockT m ()
notify
        BlockHash -> BlockT m ()
forall (m :: * -> *).
(MonadReader BlockStore m, MonadIO m) =>
BlockHash -> m ()
removeSyncingBlock (BlockHash -> BlockT m ()) -> BlockHash -> BlockT m ()
forall a b. (a -> b) -> a -> b
$ BlockHeader -> BlockHash
headerHash (BlockHeader -> BlockHash) -> BlockHeader -> BlockHash
forall a b. (a -> b) -> a -> b
$ BlockNode -> BlockHeader
nodeHeader BlockNode
node
        BlockT m ()
forall (m :: * -> *). (MonadIO m, MonadReader BlockStore m) => m ()
touchPeer
        BlockT m Bool
forall (m :: * -> *). MonadLoggerIO m => BlockT m Bool
isInSync BlockT m Bool -> (Bool -> BlockT m ()) -> BlockT m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Bool
False -> BlockT m ()
forall (m :: * -> *). MonadLoggerIO m => BlockT m ()
syncMe
            Bool
True -> do
                BlockT m ()
forall (m :: * -> *).
(StoreReadBase m, MonadLoggerIO m, MonadReader BlockStore m) =>
m ()
updateOrphans
                Peer -> BlockT m ()
forall (m :: * -> *).
(MonadUnliftIO m, MonadLoggerIO m) =>
Peer -> BlockT m ()
mempool Peer
peer
    failure :: a -> m ()
failure a
e = do
        $(Text -> Text -> m ()
logErrorS) Text
"BlockStore" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
            Text
"Error importing block " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
hexhash
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" from peer: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
peer Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (a -> String
forall a. Show a => a -> String
show a
e)
        PeerException -> Peer -> m ()
forall (m :: * -> *). MonadIO m => PeerException -> Peer -> m ()
killPeer (String -> PeerException
PeerMisbehaving (a -> String
forall a. Show a => a -> String
show a
e)) Peer
peer
    notify :: BlockT m ()
notify = do
        Publisher StoreEvent
listener <- (BlockStore -> Publisher StoreEvent)
-> ReaderT BlockStore m (Publisher StoreEvent)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (BlockStoreConfig -> Publisher StoreEvent
blockConfListener (BlockStoreConfig -> Publisher StoreEvent)
-> (BlockStore -> BlockStoreConfig)
-> BlockStore
-> Publisher StoreEvent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockStore -> BlockStoreConfig
myConfig)
        StoreEvent -> Publisher StoreEvent -> BlockT m ()
forall (m :: * -> *) msg. MonadIO m => msg -> Publisher msg -> m ()
publish (BlockHash -> StoreEvent
StoreBestBlock BlockHash
blockhash) Publisher StoreEvent
listener

setSyncingBlocks :: (MonadReader BlockStore m, MonadIO m)
                 => [BlockHash] -> m ()
setSyncingBlocks :: [BlockHash] -> m ()
setSyncingBlocks [BlockHash]
hs =
    (BlockStore -> TVar (Maybe Syncing)) -> m (TVar (Maybe Syncing))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> TVar (Maybe Syncing)
myPeer m (TVar (Maybe Syncing)) -> (TVar (Maybe Syncing) -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \TVar (Maybe Syncing)
box ->
    STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ TVar (Maybe Syncing) -> (Maybe Syncing -> Maybe Syncing) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Maybe Syncing)
box ((Maybe Syncing -> Maybe Syncing) -> STM ())
-> (Maybe Syncing -> Maybe Syncing) -> STM ()
forall a b. (a -> b) -> a -> b
$ \case
        Maybe Syncing
Nothing -> Maybe Syncing
forall a. Maybe a
Nothing
        Just Syncing
x  -> Syncing -> Maybe Syncing
forall a. a -> Maybe a
Just Syncing
x { syncingBlocks :: [BlockHash]
syncingBlocks = [BlockHash]
hs }

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

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

removeSyncingBlock :: (MonadReader BlockStore m, MonadIO m)
                   => BlockHash -> m ()
removeSyncingBlock :: BlockHash -> m ()
removeSyncingBlock BlockHash
h = do
    TVar (Maybe Syncing)
box <- (BlockStore -> TVar (Maybe Syncing)) -> m (TVar (Maybe Syncing))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> TVar (Maybe Syncing)
myPeer
    STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ TVar (Maybe Syncing) -> (Maybe Syncing -> Maybe Syncing) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Maybe Syncing)
box ((Maybe Syncing -> Maybe Syncing) -> STM ())
-> (Maybe Syncing -> Maybe Syncing) -> STM ()
forall a b. (a -> b) -> a -> b
$ \case
        Maybe Syncing
Nothing -> Maybe Syncing
forall a. Maybe a
Nothing
        Just Syncing
x  -> Syncing -> Maybe Syncing
forall a. a -> Maybe a
Just Syncing
x { syncingBlocks :: [BlockHash]
syncingBlocks = BlockHash -> [BlockHash] -> [BlockHash]
forall a. Eq a => a -> [a] -> [a]
delete BlockHash
h (Syncing -> [BlockHash]
syncingBlocks Syncing
x) }

checkPeer :: (MonadLoggerIO m, MonadReader BlockStore m) => Peer -> m Bool
checkPeer :: Peer -> m Bool
checkPeer Peer
p =
    (Syncing -> Peer) -> Maybe Syncing -> Maybe Peer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Syncing -> Peer
syncingPeer (Maybe Syncing -> Maybe Peer)
-> m (Maybe Syncing) -> m (Maybe Peer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Maybe Syncing)
forall (m :: * -> *).
(MonadIO m, MonadReader BlockStore m) =>
m (Maybe Syncing)
getSyncingState m (Maybe Peer) -> (Maybe Peer -> m Bool) -> m Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe Peer
Nothing -> Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Just Peer
p' -> Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ Peer
p Peer -> Peer -> Bool
forall a. Eq a => a -> a -> Bool
== Peer
p'

getBlockNode :: (MonadLoggerIO m, MonadReader BlockStore m)
             => BlockHash -> m (Maybe BlockNode)
getBlockNode :: BlockHash -> m (Maybe BlockNode)
getBlockNode BlockHash
blockhash =
    BlockHash -> Chain -> m (Maybe BlockNode)
forall (m :: * -> *).
MonadIO m =>
BlockHash -> Chain -> m (Maybe BlockNode)
chainGetBlock BlockHash
blockhash (Chain -> m (Maybe BlockNode)) -> m Chain -> m (Maybe BlockNode)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (BlockStore -> Chain) -> m Chain
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (BlockStoreConfig -> Chain
blockConfChain (BlockStoreConfig -> Chain)
-> (BlockStore -> BlockStoreConfig) -> BlockStore -> Chain
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockStore -> BlockStoreConfig
myConfig)

processNoBlocks ::
       MonadLoggerIO m
    => Peer
    -> [BlockHash]
    -> BlockT m ()
processNoBlocks :: Peer -> [BlockHash] -> BlockT m ()
processNoBlocks Peer
p [BlockHash]
hs = do
    [(Int, BlockHash)]
-> ((Int, BlockHash) -> BlockT m ()) -> BlockT m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Int] -> [BlockHash] -> [(Int, BlockHash)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Int
1 :: Int) ..] [BlockHash]
hs) (((Int, BlockHash) -> BlockT m ()) -> BlockT m ())
-> ((Int, BlockHash) -> BlockT m ()) -> BlockT m ()
forall a b. (a -> b) -> a -> b
$ \(Int
i, BlockHash
h) ->
        $(Text -> Text -> BlockT m ()
logErrorS) Text
"BlockStore" (Text -> BlockT m ()) -> Text -> BlockT m ()
forall a b. (a -> b) -> a -> b
$
            Text
"Block "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (Int -> String
forall a. Show a => a -> String
show Int
i) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/"
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (Int -> String
forall a. Show a => a -> String
show ([BlockHash] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BlockHash]
hs)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> BlockHash -> Text
blockHashToHex BlockHash
h
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" not found by peer: "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
    PeerException -> Peer -> BlockT m ()
forall (m :: * -> *). MonadIO m => PeerException -> Peer -> m ()
killPeer (String -> PeerException
PeerMisbehaving String
"Did not find requested block(s)") Peer
p

processTx :: MonadLoggerIO m => Peer -> Tx -> BlockT m ()
processTx :: Peer -> Tx -> BlockT m ()
processTx Peer
p Tx
tx = BlockT m () -> BlockT m ()
forall (m :: * -> *). Monad m => BlockT m () -> BlockT m ()
guardMempool (BlockT m () -> BlockT m ()) -> BlockT m () -> BlockT m ()
forall a b. (a -> b) -> a -> b
$ do
    UTCTime
t <- IO UTCTime -> ReaderT BlockStore m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
    $(Text -> Text -> BlockT m ()
logDebugS) Text
"BlockManager" (Text -> BlockT m ()) -> Text -> BlockT m ()
forall a b. (a -> b) -> a -> b
$
        Text
"Received tx " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TxHash -> Text
txHashToHex (Tx -> TxHash
txHash Tx
tx)
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" by peer: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
    PendingTx -> BlockT m ()
forall (m :: * -> *). MonadIO m => PendingTx -> BlockT m ()
addPendingTx (PendingTx -> BlockT m ()) -> PendingTx -> BlockT m ()
forall a b. (a -> b) -> a -> b
$ UTCTime -> Tx -> HashSet TxHash -> PendingTx
PendingTx UTCTime
t Tx
tx HashSet TxHash
forall a. HashSet a
HashSet.empty

pruneOrphans :: MonadIO m => BlockT m ()
pruneOrphans :: BlockT m ()
pruneOrphans = BlockT m () -> BlockT m ()
forall (m :: * -> *). Monad m => BlockT m () -> BlockT m ()
guardMempool (BlockT m () -> BlockT m ()) -> BlockT m () -> BlockT m ()
forall a b. (a -> b) -> a -> b
$ do
    TVar (HashMap TxHash PendingTx)
ts <- (BlockStore -> TVar (HashMap TxHash PendingTx))
-> ReaderT BlockStore m (TVar (HashMap TxHash PendingTx))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> TVar (HashMap TxHash PendingTx)
myTxs
    UTCTime
now <- IO UTCTime -> ReaderT BlockStore m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
    STM () -> BlockT m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> BlockT m ())
-> ((PendingTx -> Bool) -> STM ())
-> (PendingTx -> Bool)
-> BlockT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar (HashMap TxHash PendingTx)
-> (HashMap TxHash PendingTx -> HashMap TxHash PendingTx) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (HashMap TxHash PendingTx)
ts ((HashMap TxHash PendingTx -> HashMap TxHash PendingTx) -> STM ())
-> ((PendingTx -> Bool)
    -> HashMap TxHash PendingTx -> HashMap TxHash PendingTx)
-> (PendingTx -> Bool)
-> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PendingTx -> Bool)
-> HashMap TxHash PendingTx -> HashMap TxHash PendingTx
forall v k. (v -> Bool) -> HashMap k v -> HashMap k v
HashMap.filter ((PendingTx -> Bool) -> BlockT m ())
-> (PendingTx -> Bool) -> BlockT m ()
forall a b. (a -> b) -> a -> b
$ \PendingTx
p ->
        UTCTime
now UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` PendingTx -> UTCTime
pendingTxTime PendingTx
p NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
> NominalDiffTime
600

addPendingTx :: MonadIO m => PendingTx -> BlockT m ()
addPendingTx :: PendingTx -> BlockT m ()
addPendingTx PendingTx
p = do
    TVar (HashMap TxHash PendingTx)
ts <- (BlockStore -> TVar (HashMap TxHash PendingTx))
-> ReaderT BlockStore m (TVar (HashMap TxHash PendingTx))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> TVar (HashMap TxHash PendingTx)
myTxs
    TVar (HashSet TxHash)
rq <- (BlockStore -> TVar (HashSet TxHash))
-> ReaderT BlockStore m (TVar (HashSet TxHash))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> TVar (HashSet TxHash)
requested
    STM Int -> ReaderT BlockStore m Int
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Int -> ReaderT BlockStore m Int)
-> STM Int -> ReaderT BlockStore m Int
forall a b. (a -> b) -> a -> b
$ do
        TVar (HashMap TxHash PendingTx)
-> (HashMap TxHash PendingTx -> HashMap TxHash PendingTx) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (HashMap TxHash PendingTx)
ts ((HashMap TxHash PendingTx -> HashMap TxHash PendingTx) -> STM ())
-> (HashMap TxHash PendingTx -> HashMap TxHash PendingTx) -> STM ()
forall a b. (a -> b) -> a -> b
$ TxHash
-> PendingTx
-> HashMap TxHash PendingTx
-> HashMap TxHash PendingTx
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert TxHash
th PendingTx
p
        TVar (HashSet TxHash)
-> (HashSet TxHash -> HashSet TxHash) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (HashSet TxHash)
rq ((HashSet TxHash -> HashSet TxHash) -> STM ())
-> (HashSet TxHash -> HashSet TxHash) -> STM ()
forall a b. (a -> b) -> a -> b
$ TxHash -> HashSet TxHash -> HashSet TxHash
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HashSet.delete TxHash
th
        HashMap TxHash PendingTx -> Int
forall k v. HashMap k v -> Int
HashMap.size (HashMap TxHash PendingTx -> Int)
-> STM (HashMap TxHash PendingTx) -> STM Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (HashMap TxHash PendingTx) -> STM (HashMap TxHash PendingTx)
forall a. TVar a -> STM a
readTVar TVar (HashMap TxHash PendingTx)
ts
    BlockT m ()
forall (m :: * -> *). MonadIO m => BlockT m ()
setPendingTxs
  where
    th :: TxHash
th = Tx -> TxHash
txHash (PendingTx -> Tx
pendingTx PendingTx
p)

addRequestedTx :: MonadIO m => TxHash -> BlockT m ()
addRequestedTx :: TxHash -> BlockT m ()
addRequestedTx TxHash
th = do
    TVar (HashSet TxHash)
qbox <- (BlockStore -> TVar (HashSet TxHash))
-> ReaderT BlockStore m (TVar (HashSet TxHash))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> TVar (HashSet TxHash)
requested
    STM () -> BlockT m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> BlockT m ()) -> STM () -> BlockT m ()
forall a b. (a -> b) -> a -> b
$ TVar (HashSet TxHash)
-> (HashSet TxHash -> HashSet TxHash) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (HashSet TxHash)
qbox ((HashSet TxHash -> HashSet TxHash) -> STM ())
-> (HashSet TxHash -> HashSet TxHash) -> STM ()
forall a b. (a -> b) -> a -> b
$ TxHash -> HashSet TxHash -> HashSet TxHash
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HashSet.insert TxHash
th
    IO () -> BlockT m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> BlockT m ()) -> IO () -> BlockT m ()
forall a b. (a -> b) -> a -> b
$ IO (Async ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Async ()) -> IO ()) -> IO (Async ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO (Async ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ do
        Int -> IO ()
forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay Int
20000000
        STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (HashSet TxHash)
-> (HashSet TxHash -> HashSet TxHash) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (HashSet TxHash)
qbox ((HashSet TxHash -> HashSet TxHash) -> STM ())
-> (HashSet TxHash -> HashSet TxHash) -> STM ()
forall a b. (a -> b) -> a -> b
$ TxHash -> HashSet TxHash -> HashSet TxHash
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HashSet.delete TxHash
th

isPending :: MonadIO m => TxHash -> BlockT m Bool
isPending :: TxHash -> BlockT m Bool
isPending TxHash
th = do
    TVar (HashMap TxHash PendingTx)
tbox <- (BlockStore -> TVar (HashMap TxHash PendingTx))
-> ReaderT BlockStore m (TVar (HashMap TxHash PendingTx))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> TVar (HashMap TxHash PendingTx)
myTxs
    TVar (HashSet TxHash)
qbox  <- (BlockStore -> TVar (HashSet TxHash))
-> ReaderT BlockStore m (TVar (HashSet TxHash))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> TVar (HashSet TxHash)
requested
    STM Bool -> BlockT m Bool
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Bool -> BlockT m Bool) -> STM Bool -> BlockT m Bool
forall a b. (a -> b) -> a -> b
$ do
        HashMap TxHash PendingTx
ts <- TVar (HashMap TxHash PendingTx) -> STM (HashMap TxHash PendingTx)
forall a. TVar a -> STM a
readTVar TVar (HashMap TxHash PendingTx)
tbox
        HashSet TxHash
rs <- TVar (HashSet TxHash) -> STM (HashSet TxHash)
forall a. TVar a -> STM a
readTVar TVar (HashSet TxHash)
qbox
        Bool -> STM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> STM Bool) -> Bool -> STM Bool
forall a b. (a -> b) -> a -> b
$ TxHash
th TxHash -> HashMap TxHash PendingTx -> Bool
forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool
`HashMap.member` HashMap TxHash PendingTx
ts
              Bool -> Bool -> Bool
|| TxHash
th TxHash -> HashSet TxHash -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`HashSet.member` HashSet TxHash
rs

pendingTxs :: MonadIO m => Int -> BlockT m [PendingTx]
pendingTxs :: Int -> BlockT m [PendingTx]
pendingTxs Int
i = do
    [PendingTx]
selected <- (BlockStore -> TVar (HashMap TxHash PendingTx))
-> ReaderT BlockStore m (TVar (HashMap TxHash PendingTx))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> TVar (HashMap TxHash PendingTx)
myTxs ReaderT BlockStore m (TVar (HashMap TxHash PendingTx))
-> (TVar (HashMap TxHash PendingTx) -> BlockT m [PendingTx])
-> BlockT m [PendingTx]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \TVar (HashMap TxHash PendingTx)
box -> STM [PendingTx] -> BlockT m [PendingTx]
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM [PendingTx] -> BlockT m [PendingTx])
-> STM [PendingTx] -> BlockT m [PendingTx]
forall a b. (a -> b) -> a -> b
$ do
        HashMap TxHash PendingTx
pending <- TVar (HashMap TxHash PendingTx) -> STM (HashMap TxHash PendingTx)
forall a. TVar a -> STM a
readTVar TVar (HashMap TxHash PendingTx)
box
        let ([PendingTx]
selected, HashMap TxHash PendingTx
rest) = HashMap TxHash PendingTx -> ([PendingTx], HashMap TxHash PendingTx)
select HashMap TxHash PendingTx
pending
        TVar (HashMap TxHash PendingTx)
-> HashMap TxHash PendingTx -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (HashMap TxHash PendingTx)
box HashMap TxHash PendingTx
rest
        [PendingTx] -> STM [PendingTx]
forall (m :: * -> *) a. Monad m => a -> m a
return ([PendingTx]
selected)
    BlockT m ()
forall (m :: * -> *). MonadIO m => BlockT m ()
setPendingTxs
    [PendingTx] -> BlockT m [PendingTx]
forall (m :: * -> *) a. Monad m => a -> m a
return [PendingTx]
selected
  where
    select :: HashMap TxHash PendingTx -> ([PendingTx], HashMap TxHash PendingTx)
select HashMap TxHash PendingTx
pend =
        let eligible :: HashMap TxHash PendingTx
eligible = (PendingTx -> Bool)
-> HashMap TxHash PendingTx -> HashMap TxHash PendingTx
forall v k. (v -> Bool) -> HashMap k v -> HashMap k v
HashMap.filter (HashSet TxHash -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (HashSet TxHash -> Bool)
-> (PendingTx -> HashSet TxHash) -> PendingTx -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PendingTx -> HashSet TxHash
pendingDeps) HashMap TxHash PendingTx
pend
            orphans :: HashMap TxHash PendingTx
orphans = HashMap TxHash PendingTx
-> HashMap TxHash PendingTx -> HashMap TxHash PendingTx
forall k v w.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k w -> HashMap k v
HashMap.difference HashMap TxHash PendingTx
pend HashMap TxHash PendingTx
eligible
            selected :: [PendingTx]
selected = Int -> [PendingTx] -> [PendingTx]
forall a. Int -> [a] -> [a]
take Int
i ([PendingTx] -> [PendingTx]) -> [PendingTx] -> [PendingTx]
forall a b. (a -> b) -> a -> b
$ HashMap TxHash PendingTx -> [PendingTx]
sortit HashMap TxHash PendingTx
eligible
            remaining :: HashMap TxHash PendingTx
remaining = (PendingTx -> Bool)
-> HashMap TxHash PendingTx -> HashMap TxHash PendingTx
forall v k. (v -> Bool) -> HashMap k v -> HashMap k v
HashMap.filter (PendingTx -> [PendingTx] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [PendingTx]
selected) HashMap TxHash PendingTx
eligible
         in ([PendingTx]
selected, HashMap TxHash PendingTx
remaining HashMap TxHash PendingTx
-> HashMap TxHash PendingTx -> HashMap TxHash PendingTx
forall a. Semigroup a => a -> a -> a
<> HashMap TxHash PendingTx
orphans)
    sortit :: HashMap TxHash PendingTx -> [PendingTx]
sortit HashMap TxHash PendingTx
m =
        let sorted :: [(BlockHeight, Tx)]
sorted = [Tx] -> [(BlockHeight, Tx)]
sortTxs ([Tx] -> [(BlockHeight, Tx)]) -> [Tx] -> [(BlockHeight, Tx)]
forall a b. (a -> b) -> a -> b
$ (PendingTx -> Tx) -> [PendingTx] -> [Tx]
forall a b. (a -> b) -> [a] -> [b]
map PendingTx -> Tx
pendingTx ([PendingTx] -> [Tx]) -> [PendingTx] -> [Tx]
forall a b. (a -> b) -> a -> b
$ HashMap TxHash PendingTx -> [PendingTx]
forall k v. HashMap k v -> [v]
HashMap.elems HashMap TxHash PendingTx
m
            txids :: [TxHash]
txids = ((BlockHeight, Tx) -> TxHash) -> [(BlockHeight, Tx)] -> [TxHash]
forall a b. (a -> b) -> [a] -> [b]
map (Tx -> TxHash
txHash (Tx -> TxHash)
-> ((BlockHeight, Tx) -> Tx) -> (BlockHeight, Tx) -> TxHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BlockHeight, Tx) -> Tx
forall a b. (a, b) -> b
snd) [(BlockHeight, Tx)]
sorted
         in (TxHash -> Maybe PendingTx) -> [TxHash] -> [PendingTx]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (TxHash -> HashMap TxHash PendingTx -> Maybe PendingTx
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
`HashMap.lookup` HashMap TxHash PendingTx
m) [TxHash]
txids

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

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

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

importMempoolTx
    :: (MonadLoggerIO m, MonadError ImportException m)
    => BlockStore
    -> UTCTime
    -> Tx
    -> WriterT m (Maybe (HashSet TxHash))
importMempoolTx :: BlockStore -> UTCTime -> Tx -> WriterT m (Maybe (HashSet TxHash))
importMempoolTx BlockStore
block_read UTCTime
time Tx
tx =
    WriterT m (Maybe (HashSet TxHash))
-> (ImportException -> WriterT m (Maybe (HashSet TxHash)))
-> WriterT m (Maybe (HashSet TxHash))
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError WriterT m (Maybe (HashSet TxHash))
new_mempool_tx ImportException -> WriterT m (Maybe (HashSet TxHash))
forall (m :: * -> *) a.
MonadLoggerIO m =>
ImportException -> ReaderT Writer m (Maybe a)
handle_error
  where
    tx_hash :: TxHash
tx_hash = Tx -> TxHash
txHash Tx
tx
    handle_error :: ImportException -> ReaderT Writer m (Maybe a)
handle_error ImportException
Orphan = do
        BlockStore -> UTCTime -> Tx -> WriterT m ()
forall (m :: * -> *).
MonadLoggerIO m =>
BlockStore -> UTCTime -> Tx -> WriterT m ()
newOrphanTx BlockStore
block_read UTCTime
time Tx
tx
        Maybe a -> ReaderT Writer m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
    handle_error ImportException
_ = Maybe a -> ReaderT Writer m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
    seconds :: UnixTime
seconds = NominalDiffTime -> UnixTime
forall a b. (RealFrac a, Integral b) => a -> b
floor (UTCTime -> NominalDiffTime
utcTimeToPOSIXSeconds UTCTime
time)
    new_mempool_tx :: WriterT m (Maybe (HashSet TxHash))
new_mempool_tx =
        Tx -> UnixTime -> WriterT m (Maybe (HashSet TxHash))
forall (m :: * -> *).
MonadImport m =>
Tx -> UnixTime -> m (Maybe (HashSet TxHash))
newMempoolTx Tx
tx UnixTime
seconds WriterT m (Maybe (HashSet TxHash))
-> (Maybe (HashSet TxHash) -> WriterT m (Maybe (HashSet TxHash)))
-> WriterT m (Maybe (HashSet TxHash))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just HashSet TxHash
set -> do
                $(Text -> Text -> ReaderT Writer m ()
logInfoS) Text
"BlockStore" (Text -> ReaderT Writer m ()) -> Text -> ReaderT Writer m ()
forall a b. (a -> b) -> a -> b
$
                    Text
"Import tx " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TxHash -> Text
txHashToHex (Tx -> TxHash
txHash Tx
tx)
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": OK"
                BlockStore -> TxHash -> ReaderT Writer m ()
forall (m :: * -> *). MonadIO m => BlockStore -> TxHash -> m ()
fulfillOrphans BlockStore
block_read TxHash
tx_hash
                Maybe (HashSet TxHash) -> WriterT m (Maybe (HashSet TxHash))
forall (m :: * -> *) a. Monad m => a -> m a
return (HashSet TxHash -> Maybe (HashSet TxHash)
forall a. a -> Maybe a
Just HashSet TxHash
set)
            Maybe (HashSet TxHash)
Nothing -> do
                $(Text -> Text -> ReaderT Writer m ()
logDebugS) Text
"BlockStore" (Text -> ReaderT Writer m ()) -> Text -> ReaderT Writer m ()
forall a b. (a -> b) -> a -> b
$
                    Text
"Import tx " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TxHash -> Text
txHashToHex (Tx -> TxHash
txHash Tx
tx)
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": Already imported"
                Maybe (HashSet TxHash) -> WriterT m (Maybe (HashSet TxHash))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (HashSet TxHash)
forall a. Maybe a
Nothing

processMempool :: MonadLoggerIO m => BlockT m ()
processMempool :: BlockT m ()
processMempool = BlockT m () -> BlockT m ()
forall (m :: * -> *). Monad m => BlockT m () -> BlockT m ()
guardMempool (BlockT m () -> BlockT m ()) -> BlockT m () -> BlockT m ()
forall a b. (a -> b) -> a -> b
$ do
    [PendingTx]
txs <- Int -> BlockT m [PendingTx]
forall (m :: * -> *). MonadIO m => Int -> BlockT m [PendingTx]
pendingTxs Int
2000
    BlockStore
block_read <- ReaderT BlockStore m BlockStore
forall r (m :: * -> *). MonadReader r m => m r
ask
    Bool -> BlockT m () -> BlockT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([PendingTx] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PendingTx]
txs) (BlockStore
-> [PendingTx] -> ReaderT BlockStore m [(TxHash, HashSet TxHash)]
forall (m :: * -> *).
MonadLoggerIO m =>
BlockStore
-> [PendingTx] -> ReaderT BlockStore m [(TxHash, HashSet TxHash)]
import_txs BlockStore
block_read [PendingTx]
txs ReaderT BlockStore m [(TxHash, HashSet TxHash)]
-> ([(TxHash, HashSet TxHash)] -> BlockT m ()) -> BlockT m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [(TxHash, HashSet TxHash)] -> BlockT m ()
success)
  where
    run_import :: BlockStore
-> PendingTx -> ReaderT Writer m (Maybe (TxHash, HashSet TxHash))
run_import BlockStore
block_read PendingTx
p =
        BlockStore -> UTCTime -> Tx -> WriterT m (Maybe (HashSet TxHash))
forall (m :: * -> *).
(MonadLoggerIO m, MonadError ImportException m) =>
BlockStore -> UTCTime -> Tx -> WriterT m (Maybe (HashSet TxHash))
importMempoolTx
            BlockStore
block_read
            (PendingTx -> UTCTime
pendingTxTime PendingTx
p)
            (PendingTx -> Tx
pendingTx PendingTx
p) WriterT m (Maybe (HashSet TxHash))
-> (Maybe (HashSet TxHash)
    -> ReaderT Writer m (Maybe (TxHash, HashSet TxHash)))
-> ReaderT Writer m (Maybe (TxHash, HashSet TxHash))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Just HashSet TxHash
set -> Maybe (TxHash, HashSet TxHash)
-> ReaderT Writer m (Maybe (TxHash, HashSet TxHash))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (TxHash, HashSet TxHash)
 -> ReaderT Writer m (Maybe (TxHash, HashSet TxHash)))
-> Maybe (TxHash, HashSet TxHash)
-> ReaderT Writer m (Maybe (TxHash, HashSet TxHash))
forall a b. (a -> b) -> a -> b
$ (TxHash, HashSet TxHash) -> Maybe (TxHash, HashSet TxHash)
forall a. a -> Maybe a
Just (Tx -> TxHash
txHash (PendingTx -> Tx
pendingTx PendingTx
p), HashSet TxHash
set)
                Maybe (HashSet TxHash)
Nothing -> Maybe (TxHash, HashSet TxHash)
-> ReaderT Writer m (Maybe (TxHash, HashSet TxHash))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (TxHash, HashSet TxHash)
forall a. Maybe a
Nothing
    import_txs :: BlockStore
-> [PendingTx] -> ReaderT BlockStore m [(TxHash, HashSet TxHash)]
import_txs BlockStore
block_read [PendingTx]
txs =
        let r :: ReaderT
  Writer (ExceptT ImportException m) [Maybe (TxHash, HashSet TxHash)]
r = (PendingTx
 -> ReaderT
      Writer
      (ExceptT ImportException m)
      (Maybe (TxHash, HashSet TxHash)))
-> [PendingTx]
-> ReaderT
     Writer (ExceptT ImportException m) [Maybe (TxHash, HashSet TxHash)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (BlockStore
-> PendingTx
-> ReaderT
     Writer (ExceptT ImportException m) (Maybe (TxHash, HashSet TxHash))
forall (m :: * -> *).
(MonadLoggerIO m, MonadError ImportException m) =>
BlockStore
-> PendingTx -> ReaderT Writer m (Maybe (TxHash, HashSet TxHash))
run_import BlockStore
block_read) [PendingTx]
txs
         in ReaderT
  Writer (ExceptT ImportException m) [Maybe (TxHash, HashSet TxHash)]
-> BlockT
     m (Either ImportException [Maybe (TxHash, HashSet TxHash)])
forall (m :: * -> *) a.
MonadLoggerIO m =>
WriterT (ExceptT ImportException m) a
-> BlockT m (Either ImportException a)
runImport ReaderT
  Writer (ExceptT ImportException m) [Maybe (TxHash, HashSet TxHash)]
r BlockT m (Either ImportException [Maybe (TxHash, HashSet TxHash)])
-> (Either ImportException [Maybe (TxHash, HashSet TxHash)]
    -> ReaderT BlockStore m [(TxHash, HashSet TxHash)])
-> ReaderT BlockStore m [(TxHash, HashSet TxHash)]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Left ImportException
e   -> ImportException -> ReaderT BlockStore m Any
forall (m :: * -> *) e b.
(MonadLogger m, MonadIO m, Exception e) =>
e -> m b
report_error ImportException
e ReaderT BlockStore m Any
-> ReaderT BlockStore m [(TxHash, HashSet TxHash)]
-> ReaderT BlockStore m [(TxHash, HashSet TxHash)]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [(TxHash, HashSet TxHash)]
-> ReaderT BlockStore m [(TxHash, HashSet TxHash)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
            Right [Maybe (TxHash, HashSet TxHash)]
ms -> [(TxHash, HashSet TxHash)]
-> ReaderT BlockStore m [(TxHash, HashSet TxHash)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Maybe (TxHash, HashSet TxHash)] -> [(TxHash, HashSet TxHash)]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (TxHash, HashSet TxHash)]
ms)
    report_error :: e -> m b
report_error e
e = do
        $(Text -> Text -> m ()
logErrorS) Text
"BlockImport" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
            Text
"Error processing mempool: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (e -> String
forall a. Show a => a -> String
show e
e)
        e -> m b
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO e
e
    success :: [(TxHash, HashSet TxHash)] -> BlockT m ()
success = ((TxHash, HashSet TxHash) -> BlockT m ())
-> [(TxHash, HashSet TxHash)] -> BlockT m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (TxHash, HashSet TxHash) -> BlockT m ()
forall (m :: * -> *).
(MonadReader BlockStore m, MonadIO m) =>
(TxHash, HashSet TxHash) -> m ()
notify
    notify :: (TxHash, HashSet TxHash) -> m ()
notify (TxHash
txid, HashSet TxHash
set) = do
        Publisher StoreEvent
listener <- (BlockStore -> Publisher StoreEvent) -> m (Publisher StoreEvent)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (BlockStoreConfig -> Publisher StoreEvent
blockConfListener (BlockStoreConfig -> Publisher StoreEvent)
-> (BlockStore -> BlockStoreConfig)
-> BlockStore
-> Publisher StoreEvent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockStore -> BlockStoreConfig
myConfig)
        (TxHash -> m ()) -> [TxHash] -> m [()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((StoreEvent -> Publisher StoreEvent -> m ()
forall (m :: * -> *) msg. MonadIO m => msg -> Publisher msg -> m ()
`publish` Publisher StoreEvent
listener) (StoreEvent -> m ()) -> (TxHash -> StoreEvent) -> TxHash -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxHash -> StoreEvent
StoreMempoolDelete) (HashSet TxHash -> [TxHash]
forall a. HashSet a -> [a]
HashSet.toList HashSet TxHash
set)
        StoreEvent -> Publisher StoreEvent -> m ()
forall (m :: * -> *) msg. MonadIO m => msg -> Publisher msg -> m ()
publish (TxHash -> StoreEvent
StoreMempoolNew TxHash
txid) Publisher StoreEvent
listener

processTxs ::
       MonadLoggerIO m
    => Peer
    -> [TxHash]
    -> BlockT m ()
processTxs :: Peer -> [TxHash] -> BlockT m ()
processTxs Peer
p [TxHash]
hs = BlockT m () -> BlockT m ()
forall (m :: * -> *). Monad m => BlockT m () -> BlockT m ()
guardMempool (BlockT m () -> BlockT m ()) -> BlockT m () -> BlockT m ()
forall a b. (a -> b) -> a -> b
$ do
    Bool
s <- BlockT m Bool
forall (m :: * -> *). MonadLoggerIO m => BlockT m Bool
isInSync
    Bool -> BlockT m () -> BlockT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
s (BlockT m () -> BlockT m ()) -> BlockT m () -> BlockT m ()
forall a b. (a -> b) -> a -> b
$ do
        $(Text -> Text -> BlockT m ()
logDebugS) Text
"BlockStore" (Text -> BlockT m ()) -> Text -> BlockT m ()
forall a b. (a -> b) -> a -> b
$
            Text
"Received inventory with "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (Int -> String
forall a. Show a => a -> String
show ([TxHash] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TxHash]
hs))
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" transactions from peer: "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
        [TxHash]
xs <- [Maybe TxHash] -> [TxHash]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe TxHash] -> [TxHash])
-> ReaderT BlockStore m [Maybe TxHash]
-> ReaderT BlockStore m [TxHash]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> TxHash -> ReaderT BlockStore m (Maybe TxHash))
-> ReaderT BlockStore m [Maybe TxHash]
forall b.
(Int -> TxHash -> ReaderT BlockStore m b)
-> ReaderT BlockStore m [b]
zip_counter Int -> TxHash -> ReaderT BlockStore m (Maybe TxHash)
forall (m :: * -> *) a.
(MonadIO m, MonadLogger m, Show a) =>
a -> TxHash -> ReaderT BlockStore m (Maybe TxHash)
process_tx
        Bool -> BlockT m () -> BlockT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([TxHash] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TxHash]
xs) (BlockT m () -> BlockT m ()) -> BlockT m () -> BlockT m ()
forall a b. (a -> b) -> a -> b
$ [TxHash] -> BlockT m ()
forall (m :: * -> *).
MonadIO m =>
[TxHash] -> ReaderT BlockStore m ()
go [TxHash]
xs
  where
    len :: Int
len = [TxHash] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TxHash]
hs
    zip_counter :: (Int -> TxHash -> ReaderT BlockStore m b)
-> ReaderT BlockStore m [b]
zip_counter = [(Int, TxHash)]
-> ((Int, TxHash) -> ReaderT BlockStore m b)
-> ReaderT BlockStore m [b]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([Int] -> [TxHash] -> [(Int, TxHash)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Int
1 :: Int) ..] [TxHash]
hs) (((Int, TxHash) -> ReaderT BlockStore m b)
 -> ReaderT BlockStore m [b])
-> ((Int -> TxHash -> ReaderT BlockStore m b)
    -> (Int, TxHash) -> ReaderT BlockStore m b)
-> (Int -> TxHash -> ReaderT BlockStore m b)
-> ReaderT BlockStore m [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> TxHash -> ReaderT BlockStore m b)
-> (Int, TxHash) -> ReaderT BlockStore m b
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry
    process_tx :: a -> TxHash -> ReaderT BlockStore m (Maybe TxHash)
process_tx a
i TxHash
h =
        TxHash -> BlockT m Bool
forall (m :: * -> *). MonadIO m => TxHash -> BlockT m Bool
isPending TxHash
h BlockT m Bool
-> (Bool -> ReaderT BlockStore m (Maybe TxHash))
-> ReaderT BlockStore m (Maybe TxHash)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Bool
True -> do
                $(Text -> Text -> ReaderT BlockStore m ()
logDebugS) Text
"BlockStore" (Text -> ReaderT BlockStore m ())
-> Text -> ReaderT BlockStore m ()
forall a b. (a -> b) -> a -> b
$
                    Text
"Tx " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (a -> String
forall a. Show a => a -> String
show a
i) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (Int -> String
forall a. Show a => a -> String
show Int
len)
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TxHash -> Text
txHashToHex TxHash
h Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": "
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"Pending"
                Maybe TxHash -> ReaderT BlockStore m (Maybe TxHash)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe TxHash
forall a. Maybe a
Nothing
            Bool
False -> TxHash -> ReaderT BlockStore m (Maybe TxData)
forall (m :: * -> *). StoreReadBase m => TxHash -> m (Maybe TxData)
getActiveTxData TxHash
h ReaderT BlockStore m (Maybe TxData)
-> (Maybe TxData -> ReaderT BlockStore m (Maybe TxHash))
-> ReaderT BlockStore m (Maybe TxHash)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Just TxData
_ -> do
                    $(Text -> Text -> ReaderT BlockStore m ()
logDebugS) Text
"BlockStore" (Text -> ReaderT BlockStore m ())
-> Text -> ReaderT BlockStore m ()
forall a b. (a -> b) -> a -> b
$
                        Text
"Tx " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (a -> String
forall a. Show a => a -> String
show a
i) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (Int -> String
forall a. Show a => a -> String
show Int
len)
                        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TxHash -> Text
txHashToHex TxHash
h Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": "
                        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"Already Imported"
                    Maybe TxHash -> ReaderT BlockStore m (Maybe TxHash)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe TxHash
forall a. Maybe a
Nothing
                Maybe TxData
Nothing -> do
                    $(Text -> Text -> ReaderT BlockStore m ()
logDebugS) Text
"BlockStore" (Text -> ReaderT BlockStore m ())
-> Text -> ReaderT BlockStore m ()
forall a b. (a -> b) -> a -> b
$
                        Text
"Tx " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (a -> String
forall a. Show a => a -> String
show a
i) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (Int -> String
forall a. Show a => a -> String
show Int
len)
                        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TxHash -> Text
txHashToHex TxHash
h Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": "
                        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"Requesting"
                    Maybe TxHash -> ReaderT BlockStore m (Maybe TxHash)
forall (m :: * -> *) a. Monad m => a -> m a
return (TxHash -> Maybe TxHash
forall a. a -> Maybe a
Just TxHash
h)
    go :: [TxHash] -> ReaderT BlockStore m ()
go [TxHash]
xs = do
        (TxHash -> ReaderT BlockStore m ())
-> [TxHash] -> ReaderT BlockStore m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ TxHash -> ReaderT BlockStore m ()
forall (m :: * -> *). MonadIO m => TxHash -> BlockT m ()
addRequestedTx [TxHash]
xs
        Network
net <- (BlockStore -> Network) -> ReaderT BlockStore m Network
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (BlockStoreConfig -> Network
blockConfNet (BlockStoreConfig -> Network)
-> (BlockStore -> BlockStoreConfig) -> BlockStore -> Network
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockStore -> BlockStoreConfig
myConfig)
        let inv :: InvType
inv = if Network -> Bool
getSegWit Network
net then InvType
InvWitnessTx else InvType
InvTx
            vec :: [InvVector]
vec = (TxHash -> InvVector) -> [TxHash] -> [InvVector]
forall a b. (a -> b) -> [a] -> [b]
map (InvType -> Hash256 -> InvVector
InvVector InvType
inv (Hash256 -> InvVector)
-> (TxHash -> Hash256) -> TxHash -> InvVector
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxHash -> Hash256
getTxHash) [TxHash]
xs
            msg :: Message
msg = GetData -> Message
MGetData ([InvVector] -> GetData
GetData [InvVector]
vec)
        Message
msg Message -> Peer -> ReaderT BlockStore m ()
forall (m :: * -> *). MonadIO m => Message -> Peer -> m ()
`sendMessage` Peer
p

touchPeer :: ( MonadIO m
             , MonadReader BlockStore m
             )
          => m ()
touchPeer :: m ()
touchPeer =
    m (Maybe Syncing)
forall (m :: * -> *).
(MonadIO m, MonadReader BlockStore m) =>
m (Maybe Syncing)
getSyncingState m (Maybe Syncing) -> (Maybe Syncing -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe Syncing
Nothing -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just Syncing
_ -> do
            TVar (Maybe Syncing)
box <- (BlockStore -> TVar (Maybe Syncing)) -> m (TVar (Maybe Syncing))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> TVar (Maybe Syncing)
myPeer
            UTCTime
now <- IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
            STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$
                TVar (Maybe Syncing) -> (Maybe Syncing -> Maybe Syncing) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Maybe Syncing)
box ((Maybe Syncing -> Maybe Syncing) -> STM ())
-> (Maybe Syncing -> Maybe Syncing) -> STM ()
forall a b. (a -> b) -> a -> b
$
                (Syncing -> Syncing) -> Maybe Syncing -> Maybe Syncing
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Syncing -> Syncing) -> Maybe Syncing -> Maybe Syncing)
-> (Syncing -> Syncing) -> Maybe Syncing -> Maybe Syncing
forall a b. (a -> b) -> a -> b
$ \Syncing
x -> Syncing
x { syncingTime :: UTCTime
syncingTime = UTCTime
now }

checkTime :: MonadLoggerIO m => BlockT m ()
checkTime :: BlockT m ()
checkTime =
    (BlockStore -> TVar (Maybe Syncing))
-> ReaderT BlockStore m (TVar (Maybe Syncing))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> TVar (Maybe Syncing)
myPeer ReaderT BlockStore m (TVar (Maybe Syncing))
-> (TVar (Maybe Syncing) -> ReaderT BlockStore m (Maybe Syncing))
-> ReaderT BlockStore m (Maybe Syncing)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TVar (Maybe Syncing) -> ReaderT BlockStore m (Maybe Syncing)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO ReaderT BlockStore m (Maybe Syncing)
-> (Maybe Syncing -> BlockT m ()) -> BlockT m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe Syncing
Nothing -> () -> BlockT m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just Syncing { syncingTime :: Syncing -> UTCTime
syncingTime = UTCTime
t
                     , syncingPeer :: Syncing -> Peer
syncingPeer = Peer
p
                     } -> do
            UTCTime
now <- IO UTCTime -> ReaderT BlockStore m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
            NominalDiffTime
peer_time_out <- (BlockStore -> NominalDiffTime)
-> ReaderT BlockStore m NominalDiffTime
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (BlockStoreConfig -> NominalDiffTime
blockConfPeerTimeout (BlockStoreConfig -> NominalDiffTime)
-> (BlockStore -> BlockStoreConfig)
-> BlockStore
-> NominalDiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockStore -> BlockStoreConfig
myConfig)
            Bool -> BlockT m () -> BlockT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (UTCTime
now UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` UTCTime
t NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
> NominalDiffTime
peer_time_out) (BlockT m () -> BlockT m ()) -> BlockT m () -> BlockT m ()
forall a b. (a -> b) -> a -> b
$ do
                $(Text -> Text -> BlockT m ()
logErrorS) Text
"BlockStore" (Text -> BlockT m ()) -> Text -> BlockT m ()
forall a b. (a -> b) -> a -> b
$
                    Text
"Syncing peer timeout: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
                PeerException -> Peer -> BlockT m ()
forall (m :: * -> *). MonadIO m => PeerException -> Peer -> m ()
killPeer PeerException
PeerTimeout Peer
p

revertToMainChain :: MonadLoggerIO m => BlockT m ()
revertToMainChain :: BlockT m ()
revertToMainChain = do
    BlockHash
h <- BlockHeader -> BlockHash
headerHash (BlockHeader -> BlockHash)
-> (BlockNode -> BlockHeader) -> BlockNode -> BlockHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockNode -> BlockHeader
nodeHeader (BlockNode -> BlockHash)
-> ReaderT BlockStore m BlockNode -> ReaderT BlockStore m BlockHash
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT BlockStore m BlockNode
forall (m :: * -> *). MonadLoggerIO m => BlockT m BlockNode
getBest
    Chain
ch <- (BlockStore -> Chain) -> ReaderT BlockStore m Chain
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (BlockStoreConfig -> Chain
blockConfChain (BlockStoreConfig -> Chain)
-> (BlockStore -> BlockStoreConfig) -> BlockStore -> Chain
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockStore -> BlockStoreConfig
myConfig)
    BlockHash -> Chain -> ReaderT BlockStore m Bool
forall (m :: * -> *). MonadIO m => BlockHash -> Chain -> m Bool
chainBlockMain BlockHash
h Chain
ch ReaderT BlockStore m Bool -> (Bool -> BlockT m ()) -> BlockT m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
x -> Bool -> BlockT m () -> BlockT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
x (BlockT m () -> BlockT m ()) -> BlockT m () -> BlockT m ()
forall a b. (a -> b) -> a -> b
$ do
        $(Text -> Text -> BlockT m ()
logWarnS) Text
"BlockStore" (Text -> BlockT m ()) -> Text -> BlockT m ()
forall a b. (a -> b) -> a -> b
$
            Text
"Reverting best block: "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> BlockHash -> Text
blockHashToHex BlockHash
h
        WriterT (ExceptT ImportException m) ()
-> BlockT m (Either ImportException ())
forall (m :: * -> *) a.
MonadLoggerIO m =>
WriterT (ExceptT ImportException m) a
-> BlockT m (Either ImportException a)
runImport (BlockHash -> WriterT (ExceptT ImportException m) ()
forall (m :: * -> *). MonadImport m => BlockHash -> m ()
revertBlock BlockHash
h) BlockT m (Either ImportException ())
-> (Either ImportException () -> BlockT m ()) -> BlockT m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Left ImportException
e -> do
                $(Text -> Text -> BlockT m ()
logErrorS) Text
"BlockStore" (Text -> BlockT m ()) -> Text -> BlockT m ()
forall a b. (a -> b) -> a -> b
$
                    Text
"Could not revert block "
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> BlockHash -> Text
blockHashToHex BlockHash
h
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (ImportException -> String
forall a. Show a => a -> String
show ImportException
e)
                ImportException -> BlockT m ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO ImportException
e
            Right () -> [BlockHash] -> BlockT m ()
forall (m :: * -> *).
(MonadReader BlockStore m, MonadIO m) =>
[BlockHash] -> m ()
setSyncingBlocks []
        BlockT m ()
forall (m :: * -> *). MonadLoggerIO m => BlockT m ()
revertToMainChain

getBest :: MonadLoggerIO m => BlockT m BlockNode
getBest :: BlockT m BlockNode
getBest = do
    BlockHash
bb <- ReaderT BlockStore m (Maybe BlockHash)
forall (m :: * -> *). StoreReadBase m => m (Maybe BlockHash)
getBestBlock ReaderT BlockStore m (Maybe BlockHash)
-> (Maybe BlockHash -> ReaderT BlockStore m BlockHash)
-> ReaderT BlockStore m BlockHash
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just BlockHash
b -> BlockHash -> ReaderT BlockStore m BlockHash
forall (m :: * -> *) a. Monad m => a -> m a
return BlockHash
b
        Maybe BlockHash
Nothing -> do
            $(Text -> Text -> ReaderT BlockStore m ()
logErrorS) Text
"BlockStore" Text
"No best block set"
            BlockException -> ReaderT BlockStore m BlockHash
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO BlockException
Uninitialized
    Chain
ch <- (BlockStore -> Chain) -> ReaderT BlockStore m Chain
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (BlockStoreConfig -> Chain
blockConfChain (BlockStoreConfig -> Chain)
-> (BlockStore -> BlockStoreConfig) -> BlockStore -> Chain
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockStore -> BlockStoreConfig
myConfig)
    BlockHash -> Chain -> ReaderT BlockStore m (Maybe BlockNode)
forall (m :: * -> *).
MonadIO m =>
BlockHash -> Chain -> m (Maybe BlockNode)
chainGetBlock BlockHash
bb Chain
ch ReaderT BlockStore m (Maybe BlockNode)
-> (Maybe BlockNode -> BlockT m BlockNode) -> BlockT m BlockNode
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just BlockNode
x -> BlockNode -> BlockT m BlockNode
forall (m :: * -> *) a. Monad m => a -> m a
return BlockNode
x
        Maybe BlockNode
Nothing -> do
            $(Text -> Text -> ReaderT BlockStore m ()
logErrorS) Text
"BlockStore" (Text -> ReaderT BlockStore m ())
-> Text -> ReaderT BlockStore m ()
forall a b. (a -> b) -> a -> b
$
                Text
"Header not found for best block: "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> BlockHash -> Text
blockHashToHex BlockHash
bb
            BlockException -> BlockT m BlockNode
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (BlockHash -> BlockException
BlockNotInChain BlockHash
bb)

getSyncBest :: MonadLoggerIO m => BlockT m BlockNode
getSyncBest :: BlockT m BlockNode
getSyncBest = do
    BlockHash
bb <- ReaderT BlockStore m [BlockHash]
forall (m :: * -> *).
(MonadReader BlockStore m, MonadIO m) =>
m [BlockHash]
getSyncingBlocks ReaderT BlockStore m [BlockHash]
-> ([BlockHash] -> ReaderT BlockStore m BlockHash)
-> ReaderT BlockStore m BlockHash
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        [] -> ReaderT BlockStore m (Maybe BlockHash)
forall (m :: * -> *). StoreReadBase m => m (Maybe BlockHash)
getBestBlock ReaderT BlockStore m (Maybe BlockHash)
-> (Maybe BlockHash -> ReaderT BlockStore m BlockHash)
-> ReaderT BlockStore m BlockHash
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just BlockHash
b -> BlockHash -> ReaderT BlockStore m BlockHash
forall (m :: * -> *) a. Monad m => a -> m a
return BlockHash
b
            Maybe BlockHash
Nothing -> do
                $(Text -> Text -> ReaderT BlockStore m ()
logErrorS) Text
"BlockStore" Text
"No best block set"
                BlockException -> ReaderT BlockStore m BlockHash
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO BlockException
Uninitialized
        [BlockHash]
hs -> BlockHash -> ReaderT BlockStore m BlockHash
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockHash -> ReaderT BlockStore m BlockHash)
-> BlockHash -> ReaderT BlockStore m BlockHash
forall a b. (a -> b) -> a -> b
$ [BlockHash] -> BlockHash
forall a. [a] -> a
last [BlockHash]
hs
    Chain
ch <- (BlockStore -> Chain) -> ReaderT BlockStore m Chain
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (BlockStoreConfig -> Chain
blockConfChain (BlockStoreConfig -> Chain)
-> (BlockStore -> BlockStoreConfig) -> BlockStore -> Chain
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockStore -> BlockStoreConfig
myConfig)
    BlockHash -> Chain -> ReaderT BlockStore m (Maybe BlockNode)
forall (m :: * -> *).
MonadIO m =>
BlockHash -> Chain -> m (Maybe BlockNode)
chainGetBlock BlockHash
bb Chain
ch ReaderT BlockStore m (Maybe BlockNode)
-> (Maybe BlockNode -> BlockT m BlockNode) -> BlockT m BlockNode
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just BlockNode
x -> BlockNode -> BlockT m BlockNode
forall (m :: * -> *) a. Monad m => a -> m a
return BlockNode
x
        Maybe BlockNode
Nothing -> do
            $(Text -> Text -> ReaderT BlockStore m ()
logErrorS) Text
"BlockStore" (Text -> ReaderT BlockStore m ())
-> Text -> ReaderT BlockStore m ()
forall a b. (a -> b) -> a -> b
$
                Text
"Header not found for block: "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> BlockHash -> Text
blockHashToHex BlockHash
bb
            BlockException -> BlockT m BlockNode
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (BlockHash -> BlockException
BlockNotInChain BlockHash
bb)

shouldSync :: MonadLoggerIO m => BlockT m (Maybe Peer)
shouldSync :: BlockT m (Maybe Peer)
shouldSync =
    BlockT m Bool
forall (m :: * -> *). MonadLoggerIO m => BlockT m Bool
isInSync BlockT m Bool
-> (Bool -> BlockT m (Maybe Peer)) -> BlockT m (Maybe Peer)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Bool
True -> Maybe Peer -> BlockT m (Maybe Peer)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Peer
forall a. Maybe a
Nothing
        Bool
False -> ReaderT BlockStore m (Maybe Syncing)
forall (m :: * -> *).
(MonadIO m, MonadReader BlockStore m) =>
m (Maybe Syncing)
getSyncingState ReaderT BlockStore m (Maybe Syncing)
-> (Maybe Syncing -> BlockT m (Maybe Peer))
-> BlockT m (Maybe Peer)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Maybe Syncing
Nothing -> Maybe Peer -> BlockT m (Maybe Peer)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Peer
forall a. Maybe a
Nothing
            Just Syncing { syncingPeer :: Syncing -> Peer
syncingPeer = Peer
p, syncingBlocks :: Syncing -> [BlockHash]
syncingBlocks = [BlockHash]
bs }
                | Int
100 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> [BlockHash] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BlockHash]
bs -> Maybe Peer -> BlockT m (Maybe Peer)
forall (m :: * -> *) a. Monad m => a -> m a
return (Peer -> Maybe Peer
forall a. a -> Maybe a
Just Peer
p)
                | Bool
otherwise -> Maybe Peer -> BlockT m (Maybe Peer)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Peer
forall a. Maybe a
Nothing

syncMe :: MonadLoggerIO m => BlockT m ()
syncMe :: BlockT m ()
syncMe = do
    BlockT m ()
forall (m :: * -> *). MonadLoggerIO m => BlockT m ()
revertToMainChain
    BlockT m (Maybe Peer)
forall (m :: * -> *). MonadLoggerIO m => BlockT m (Maybe Peer)
shouldSync BlockT m (Maybe Peer) -> (Maybe Peer -> BlockT m ()) -> BlockT m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe Peer
Nothing -> () -> BlockT m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just Peer
p -> do
            BlockNode
bb <- BlockT m BlockNode
forall (m :: * -> *). MonadLoggerIO m => BlockT m BlockNode
getSyncBest
            BlockNode
bh <- BlockT m BlockNode
getbh
            Bool -> BlockT m () -> BlockT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BlockNode
bb BlockNode -> BlockNode -> Bool
forall a. Eq a => a -> a -> Bool
/= BlockNode
bh) (BlockT m () -> BlockT m ()) -> BlockT m () -> BlockT m ()
forall a b. (a -> b) -> a -> b
$ do
                [BlockNode]
bns <- BlockNode -> BlockNode -> ReaderT BlockStore m [BlockNode]
forall (m :: * -> *).
(MonadLoggerIO m, MonadReader BlockStore m) =>
BlockNode -> BlockNode -> m [BlockNode]
sel BlockNode
bb BlockNode
bh
                [InvVector]
iv <- [BlockNode] -> ReaderT BlockStore m [InvVector]
forall (m :: * -> *).
MonadReader BlockStore m =>
[BlockNode] -> m [InvVector]
getiv [BlockNode]
bns
                $(Text -> Text -> BlockT m ()
logDebugS) Text
"BlockStore" (Text -> BlockT m ()) -> Text -> BlockT m ()
forall a b. (a -> b) -> a -> b
$
                    Text
"Requesting "
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. IsString a => String -> a
fromString (Int -> String
forall a. Show a => a -> String
show ([InvVector] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [InvVector]
iv))
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" blocks from peer: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
                [BlockHash] -> BlockT m ()
forall (m :: * -> *).
(MonadReader BlockStore m, MonadIO m) =>
[BlockHash] -> m ()
addSyncingBlocks ([BlockHash] -> BlockT m ()) -> [BlockHash] -> BlockT m ()
forall a b. (a -> b) -> a -> b
$ (BlockNode -> BlockHash) -> [BlockNode] -> [BlockHash]
forall a b. (a -> b) -> [a] -> [b]
map (BlockHeader -> BlockHash
headerHash (BlockHeader -> BlockHash)
-> (BlockNode -> BlockHeader) -> BlockNode -> BlockHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockNode -> BlockHeader
nodeHeader) [BlockNode]
bns
                GetData -> Message
MGetData ([InvVector] -> GetData
GetData [InvVector]
iv) Message -> Peer -> BlockT m ()
forall (m :: * -> *). MonadIO m => Message -> Peer -> m ()
`sendMessage` Peer
p
  where
    getiv :: [BlockNode] -> m [InvVector]
getiv [BlockNode]
bns = do
        Bool
w <- Network -> Bool
getSegWit (Network -> Bool) -> m Network -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (BlockStore -> Network) -> m Network
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (BlockStoreConfig -> Network
blockConfNet (BlockStoreConfig -> Network)
-> (BlockStore -> BlockStoreConfig) -> BlockStore -> Network
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockStore -> BlockStoreConfig
myConfig)
        let i :: InvType
i = if Bool
w then InvType
InvWitnessBlock else InvType
InvBlock
            f :: BlockNode -> InvVector
f = InvType -> Hash256 -> InvVector
InvVector InvType
i (Hash256 -> InvVector)
-> (BlockNode -> Hash256) -> BlockNode -> InvVector
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockHash -> Hash256
getBlockHash (BlockHash -> Hash256)
-> (BlockNode -> BlockHash) -> BlockNode -> Hash256
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockHeader -> BlockHash
headerHash (BlockHeader -> BlockHash)
-> (BlockNode -> BlockHeader) -> BlockNode -> BlockHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockNode -> BlockHeader
nodeHeader
        [InvVector] -> m [InvVector]
forall (m :: * -> *) a. Monad m => a -> m a
return ([InvVector] -> m [InvVector]) -> [InvVector] -> m [InvVector]
forall a b. (a -> b) -> a -> b
$ (BlockNode -> InvVector) -> [BlockNode] -> [InvVector]
forall a b. (a -> b) -> [a] -> [b]
map BlockNode -> InvVector
f [BlockNode]
bns
    getbh :: BlockT m BlockNode
getbh =
        Chain -> BlockT m BlockNode
forall (m :: * -> *). MonadIO m => Chain -> m BlockNode
chainGetBest (Chain -> BlockT m BlockNode)
-> ReaderT BlockStore m Chain -> BlockT m BlockNode
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (BlockStore -> Chain) -> ReaderT BlockStore m Chain
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (BlockStoreConfig -> Chain
blockConfChain (BlockStoreConfig -> Chain)
-> (BlockStore -> BlockStoreConfig) -> BlockStore -> Chain
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockStore -> BlockStoreConfig
myConfig)
    sel :: BlockNode -> BlockNode -> m [BlockNode]
sel BlockNode
bb BlockNode
bh = do
        let sh :: BlockHeight
sh = BlockNode -> BlockNode -> BlockHeight
geth BlockNode
bb BlockNode
bh
        BlockNode
t <- BlockHeight -> BlockNode -> m BlockNode
forall (m :: * -> *).
(MonadLoggerIO m, MonadReader BlockStore m) =>
BlockHeight -> BlockNode -> m BlockNode
top BlockHeight
sh BlockNode
bh
        Chain
ch <- (BlockStore -> Chain) -> m Chain
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (BlockStoreConfig -> Chain
blockConfChain (BlockStoreConfig -> Chain)
-> (BlockStore -> BlockStoreConfig) -> BlockStore -> Chain
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockStore -> BlockStoreConfig
myConfig)
        [BlockNode]
ps <- BlockHeight -> BlockNode -> Chain -> m [BlockNode]
forall (m :: * -> *).
MonadIO m =>
BlockHeight -> BlockNode -> Chain -> m [BlockNode]
chainGetParents (BlockNode -> BlockHeight
nodeHeight BlockNode
bb BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
+ BlockHeight
1) BlockNode
t Chain
ch
        [BlockNode] -> m [BlockNode]
forall (m :: * -> *) a. Monad m => a -> m a
return ([BlockNode] -> m [BlockNode]) -> [BlockNode] -> m [BlockNode]
forall a b. (a -> b) -> a -> b
$ if Int
500 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> [BlockNode] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BlockNode]
ps
                 then [BlockNode]
ps [BlockNode] -> [BlockNode] -> [BlockNode]
forall a. Semigroup a => a -> a -> a
<> [BlockNode
bh]
                 else [BlockNode]
ps
    geth :: BlockNode -> BlockNode -> BlockHeight
geth BlockNode
bb BlockNode
bh =
        BlockHeight -> BlockHeight -> BlockHeight
forall a. Ord a => a -> a -> a
min (BlockNode -> BlockHeight
nodeHeight BlockNode
bb BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
+ BlockHeight
501)
            (BlockNode -> BlockHeight
nodeHeight BlockNode
bh)
    top :: BlockHeight -> BlockNode -> m BlockNode
top BlockHeight
sh BlockNode
bh =
        if BlockHeight
sh BlockHeight -> BlockHeight -> Bool
forall a. Eq a => a -> a -> Bool
== BlockNode -> BlockHeight
nodeHeight BlockNode
bh
        then BlockNode -> m BlockNode
forall (m :: * -> *) a. Monad m => a -> m a
return BlockNode
bh
        else BlockHeight -> BlockNode -> m BlockNode
forall (m :: * -> *).
(MonadLoggerIO m, MonadReader BlockStore m) =>
BlockHeight -> BlockNode -> m BlockNode
findAncestor BlockHeight
sh BlockNode
bh

findAncestor :: (MonadLoggerIO m, MonadReader BlockStore m)
             => BlockHeight -> BlockNode -> m BlockNode
findAncestor :: BlockHeight -> BlockNode -> m BlockNode
findAncestor BlockHeight
height BlockNode
target = do
    Chain
ch <- (BlockStore -> Chain) -> m Chain
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (BlockStoreConfig -> Chain
blockConfChain (BlockStoreConfig -> Chain)
-> (BlockStore -> BlockStoreConfig) -> BlockStore -> Chain
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockStore -> BlockStoreConfig
myConfig)
    BlockHeight -> BlockNode -> Chain -> m (Maybe BlockNode)
forall (m :: * -> *).
MonadIO m =>
BlockHeight -> BlockNode -> Chain -> m (Maybe BlockNode)
chainGetAncestor BlockHeight
height BlockNode
target Chain
ch m (Maybe BlockNode)
-> (Maybe BlockNode -> m BlockNode) -> m BlockNode
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just BlockNode
ancestor -> BlockNode -> m BlockNode
forall (m :: * -> *) a. Monad m => a -> m a
return BlockNode
ancestor
        Maybe BlockNode
Nothing -> do
            let h :: BlockHash
h = BlockHeader -> BlockHash
headerHash (BlockHeader -> BlockHash) -> BlockHeader -> BlockHash
forall a b. (a -> b) -> a -> b
$ BlockNode -> BlockHeader
nodeHeader BlockNode
target
            $(Text -> Text -> m ()
logErrorS) Text
"BlockStore" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
                Text
"Could not find header for ancestor of block "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> BlockHash -> Text
blockHashToHex BlockHash
h Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" at height "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (BlockHeight -> String
forall a. Show a => a -> String
show (BlockNode -> BlockHeight
nodeHeight BlockNode
target))
            BlockException -> m BlockNode
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (BlockException -> m BlockNode) -> BlockException -> m BlockNode
forall a b. (a -> b) -> a -> b
$ BlockHeight -> BlockHash -> BlockException
AncestorNotInChain BlockHeight
height BlockHash
h

finishPeer :: (MonadLoggerIO m, MonadReader BlockStore m)
           => Peer -> m ()
finishPeer :: Peer -> m ()
finishPeer Peer
p = do
    TVar (Maybe Syncing)
box <- (BlockStore -> TVar (Maybe Syncing)) -> m (TVar (Maybe Syncing))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> TVar (Maybe Syncing)
myPeer
    TVar (Maybe Syncing) -> m (Maybe Syncing)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar (Maybe Syncing)
box m (Maybe Syncing) -> (Maybe Syncing -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just Syncing { syncingPeer :: Syncing -> Peer
syncingPeer = Peer
p' } | Peer
p Peer -> Peer -> Bool
forall a. Eq a => a -> a -> Bool
== Peer
p' -> TVar (Maybe Syncing) -> m ()
forall (m :: * -> *) a.
(MonadIO m, MonadLogger m) =>
TVar (Maybe a) -> m ()
reset_it TVar (Maybe Syncing)
box
        Maybe Syncing
_                                           -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    reset_it :: TVar (Maybe a) -> m ()
reset_it TVar (Maybe a)
box = do
        STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ TVar (Maybe a) -> Maybe a -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe a)
box Maybe a
forall a. Maybe a
Nothing
        $(Text -> Text -> m ()
logDebugS) Text
"BlockStore" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Releasing peer: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
        Peer -> m ()
forall (m :: * -> *). MonadIO m => Peer -> m ()
setFree Peer
p

trySetPeer :: MonadLoggerIO m => Peer -> BlockT m Bool
trySetPeer :: Peer -> BlockT m Bool
trySetPeer Peer
p =
    ReaderT BlockStore m (Maybe Syncing)
forall (m :: * -> *).
(MonadIO m, MonadReader BlockStore m) =>
m (Maybe Syncing)
getSyncingState ReaderT BlockStore m (Maybe Syncing)
-> (Maybe Syncing -> BlockT m Bool) -> BlockT m Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just Syncing
_  -> Bool -> BlockT m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Maybe Syncing
Nothing -> BlockT m Bool
set_it
  where
    set_it :: BlockT m Bool
set_it =
        Peer -> BlockT m Bool
forall (m :: * -> *). MonadIO m => Peer -> m Bool
setBusy Peer
p BlockT m Bool -> (Bool -> BlockT m Bool) -> BlockT m Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Bool
False -> Bool -> BlockT m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
            Bool
True -> do
                $(Text -> Text -> ReaderT BlockStore m ()
logDebugS) Text
"BlockStore" (Text -> ReaderT BlockStore m ())
-> Text -> ReaderT BlockStore m ()
forall a b. (a -> b) -> a -> b
$
                    Text
"Locked peer: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Peer -> Text
peerText Peer
p
                TVar (Maybe Syncing)
box <- (BlockStore -> TVar (Maybe Syncing))
-> ReaderT BlockStore m (TVar (Maybe Syncing))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> TVar (Maybe Syncing)
myPeer
                UTCTime
now <- IO UTCTime -> ReaderT BlockStore m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
                STM () -> ReaderT BlockStore m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ReaderT BlockStore m ())
-> (Maybe Syncing -> STM ())
-> Maybe Syncing
-> ReaderT BlockStore m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar (Maybe Syncing) -> Maybe Syncing -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe Syncing)
box (Maybe Syncing -> ReaderT BlockStore m ())
-> Maybe Syncing -> ReaderT BlockStore m ()
forall a b. (a -> b) -> a -> b
$
                    Syncing -> Maybe Syncing
forall a. a -> Maybe a
Just Syncing :: Peer -> UTCTime -> [BlockHash] -> Syncing
Syncing { syncingPeer :: Peer
syncingPeer = Peer
p
                                  , syncingTime :: UTCTime
syncingTime = UTCTime
now
                                  , syncingBlocks :: [BlockHash]
syncingBlocks = []
                                  }
                Bool -> BlockT m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

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

trySyncingPeer :: (MonadUnliftIO m, MonadLoggerIO m) => Peer -> BlockT m ()
trySyncingPeer :: Peer -> BlockT m ()
trySyncingPeer Peer
p =
    BlockT m Bool
forall (m :: * -> *). MonadLoggerIO m => BlockT m Bool
isInSync BlockT m Bool -> (Bool -> BlockT m ()) -> BlockT m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Bool
True -> Peer -> BlockT m ()
forall (m :: * -> *).
(MonadUnliftIO m, MonadLoggerIO m) =>
Peer -> BlockT m ()
mempool Peer
p
        Bool
False -> Peer -> BlockT m Bool
forall (m :: * -> *). MonadLoggerIO m => Peer -> BlockT m Bool
trySetPeer Peer
p BlockT m Bool -> (Bool -> BlockT m ()) -> BlockT m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Bool
False -> () -> BlockT m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Bool
True  -> BlockT m ()
forall (m :: * -> *). MonadLoggerIO m => BlockT m ()
syncMe

getSyncingState
    :: (MonadIO m, MonadReader BlockStore m) => m (Maybe Syncing)
getSyncingState :: m (Maybe Syncing)
getSyncingState =
    TVar (Maybe Syncing) -> m (Maybe Syncing)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (TVar (Maybe Syncing) -> m (Maybe Syncing))
-> m (TVar (Maybe Syncing)) -> m (Maybe Syncing)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (BlockStore -> TVar (Maybe Syncing)) -> m (TVar (Maybe Syncing))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> TVar (Maybe Syncing)
myPeer

clearSyncingState
    :: (MonadLoggerIO m, MonadReader BlockStore m) => m ()
clearSyncingState :: m ()
clearSyncingState =
    (BlockStore -> TVar (Maybe Syncing)) -> m (TVar (Maybe Syncing))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BlockStore -> TVar (Maybe Syncing)
myPeer m (TVar (Maybe Syncing))
-> (TVar (Maybe Syncing) -> m (Maybe Syncing)) -> m (Maybe Syncing)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TVar (Maybe Syncing) -> m (Maybe Syncing)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO m (Maybe Syncing) -> (Maybe Syncing -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe Syncing
Nothing                          -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just Syncing { syncingPeer :: Syncing -> Peer
syncingPeer = Peer
p } -> Peer -> m ()
forall (m :: * -> *).
(MonadLoggerIO m, MonadReader BlockStore m) =>
Peer -> m ()
finishPeer Peer
p

processBlockStoreMessage :: (MonadUnliftIO m, MonadLoggerIO m)
                         => BlockStoreMessage -> BlockT m ()

processBlockStoreMessage :: BlockStoreMessage -> BlockT m ()
processBlockStoreMessage (BlockNewBest BlockNode
_) =
    BlockT m ()
forall (m :: * -> *). MonadLoggerIO m => BlockT m ()
trySyncing

processBlockStoreMessage (BlockPeerConnect Peer
p) =
    Peer -> BlockT m ()
forall (m :: * -> *).
(MonadUnliftIO m, MonadLoggerIO m) =>
Peer -> BlockT m ()
trySyncingPeer Peer
p

processBlockStoreMessage (BlockPeerDisconnect Peer
p) =
    Peer -> BlockT m ()
forall (m :: * -> *).
(MonadLoggerIO m, MonadReader BlockStore m) =>
Peer -> m ()
finishPeer Peer
p

processBlockStoreMessage (BlockReceived Peer
p Block
b) =
    Peer -> Block -> BlockT m ()
forall (m :: * -> *).
(MonadUnliftIO m, MonadLoggerIO m) =>
Peer -> Block -> BlockT m ()
processBlock Peer
p Block
b

processBlockStoreMessage (BlockNotFound Peer
p [BlockHash]
bs) =
    Peer -> [BlockHash] -> BlockT m ()
forall (m :: * -> *).
MonadLoggerIO m =>
Peer -> [BlockHash] -> BlockT m ()
processNoBlocks Peer
p [BlockHash]
bs

processBlockStoreMessage (TxRefReceived Peer
p Tx
tx) =
    Peer -> Tx -> BlockT m ()
forall (m :: * -> *). MonadLoggerIO m => Peer -> Tx -> BlockT m ()
processTx Peer
p Tx
tx

processBlockStoreMessage (TxRefAvailable Peer
p [TxHash]
ts) =
    Peer -> [TxHash] -> BlockT m ()
forall (m :: * -> *).
MonadLoggerIO m =>
Peer -> [TxHash] -> BlockT m ()
processTxs Peer
p [TxHash]
ts

processBlockStoreMessage (BlockPing Listen ()
r) = do
    BlockT m ()
forall (m :: * -> *). MonadIO m => BlockT m ()
setStoreHeight
    BlockT m ()
forall (m :: * -> *). MonadIO m => BlockT m ()
setHeadersHeight
    BlockT m ()
forall (m :: * -> *). MonadIO m => BlockT m ()
setPendingTxs
    BlockT m ()
forall (m :: * -> *). MonadIO m => BlockT m ()
setPeersConnected
    BlockT m ()
forall (m :: * -> *). MonadIO m => BlockT m ()
setMempoolSize
    BlockT m ()
forall (m :: * -> *). MonadLoggerIO m => BlockT m ()
trySyncing
    BlockT m ()
forall (m :: * -> *). MonadLoggerIO m => BlockT m ()
processMempool
    BlockT m ()
forall (m :: * -> *). MonadIO m => BlockT m ()
pruneOrphans
    BlockT m ()
forall (m :: * -> *). MonadLoggerIO m => BlockT m ()
checkTime
    STM () -> BlockT m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (Listen ()
r ())

pingMe :: MonadLoggerIO m => Mailbox BlockStoreMessage -> m ()
pingMe :: Mailbox BlockStoreMessage -> m ()
pingMe Mailbox BlockStoreMessage
mbox =
    m () -> m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        Listen () -> BlockStoreMessage
BlockPing (Listen () -> BlockStoreMessage)
-> Mailbox BlockStoreMessage -> m ()
forall (m :: * -> *) (mbox :: * -> *) response request.
(MonadIO m, OutChan mbox) =>
(Listen response -> request) -> mbox request -> m response
`query` Mailbox BlockStoreMessage
mbox
        Int
delay <- IO Int -> m Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> m Int) -> IO Int -> m Int
forall a b. (a -> b) -> a -> b
$
            (Int, Int) -> IO Int
forall a (m :: * -> *). (Random a, MonadIO m) => (a, a) -> m a
randomRIO (  Int
100 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000
                      , Int
1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000 )
        Int -> m ()
forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay Int
delay

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

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

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

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

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

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

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

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

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

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

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

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

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

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

blockStorePendingTxs
    :: MonadIO m => BlockStore -> m Int
blockStorePendingTxs :: BlockStore -> m Int
blockStorePendingTxs =
    STM Int -> m Int
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Int -> m Int)
-> (BlockStore -> STM Int) -> BlockStore -> m Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockStore -> STM Int
blockStorePendingTxsSTM

blockStorePendingTxsSTM
    :: BlockStore -> STM Int
blockStorePendingTxsSTM :: BlockStore -> STM Int
blockStorePendingTxsSTM BlockStore {Maybe StoreMetrics
TVar (Maybe Syncing)
TVar (HashMap TxHash PendingTx)
TVar (HashSet TxHash)
Mailbox BlockStoreMessage
BlockStoreConfig
myMetrics :: Maybe StoreMetrics
requested :: TVar (HashSet TxHash)
myTxs :: TVar (HashMap TxHash PendingTx)
myPeer :: TVar (Maybe Syncing)
myConfig :: BlockStoreConfig
myMailbox :: Mailbox BlockStoreMessage
myMetrics :: BlockStore -> Maybe StoreMetrics
requested :: BlockStore -> TVar (HashSet TxHash)
myTxs :: BlockStore -> TVar (HashMap TxHash PendingTx)
myPeer :: BlockStore -> TVar (Maybe Syncing)
myConfig :: BlockStore -> BlockStoreConfig
myMailbox :: BlockStore -> Mailbox BlockStoreMessage
..} = do
    HashSet TxHash
x <- HashMap TxHash PendingTx -> HashSet TxHash
forall k a. HashMap k a -> HashSet k
HashMap.keysSet (HashMap TxHash PendingTx -> HashSet TxHash)
-> STM (HashMap TxHash PendingTx) -> STM (HashSet TxHash)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (HashMap TxHash PendingTx) -> STM (HashMap TxHash PendingTx)
forall a. TVar a -> STM a
readTVar TVar (HashMap TxHash PendingTx)
myTxs
    HashSet TxHash
y <- TVar (HashSet TxHash) -> STM (HashSet TxHash)
forall a. TVar a -> STM a
readTVar TVar (HashSet TxHash)
requested
    Int -> STM Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> STM Int) -> Int -> STM Int
forall a b. (a -> b) -> a -> b
$ HashSet TxHash -> Int
forall a. HashSet a -> Int
HashSet.size (HashSet TxHash -> Int) -> HashSet TxHash -> Int
forall a b. (a -> b) -> a -> b
$ HashSet TxHash
x HashSet TxHash -> HashSet TxHash -> HashSet TxHash
forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
`HashSet.union` HashSet TxHash
y

blockText :: BlockNode -> Maybe Block -> Text
blockText :: BlockNode -> Maybe Block -> Text
blockText BlockNode
bn Maybe Block
mblock = case Maybe Block
mblock of
    Maybe Block
Nothing ->
        Text
height Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
sep Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
time Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
sep Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
hash
    Just Block
block ->
        Text
height Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
sep Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
time Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
sep Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
hash Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
sep Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Block -> Text
size Block
block
  where
    height :: Text
height = String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ BlockHeight -> String
forall a. Show a => a -> String
show (BlockNode -> BlockHeight
nodeHeight BlockNode
bn)
    systime :: UTCTime
systime = NominalDiffTime -> UTCTime
posixSecondsToUTCTime
            (NominalDiffTime -> UTCTime) -> NominalDiffTime -> UTCTime
forall a b. (a -> b) -> a -> b
$ BlockHeight -> NominalDiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral
            (BlockHeight -> NominalDiffTime) -> BlockHeight -> NominalDiffTime
forall a b. (a -> b) -> a -> b
$ BlockHeader -> BlockHeight
blockTimestamp
            (BlockHeader -> BlockHeight) -> BlockHeader -> BlockHeight
forall a b. (a -> b) -> a -> b
$ BlockNode -> BlockHeader
nodeHeader BlockNode
bn
    time :: Text
time =
        String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime
                TimeLocale
defaultTimeLocale
                (Maybe String -> String
iso8601DateFormat (String -> Maybe String
forall a. a -> Maybe a
Just String
"%H:%M"))
                UTCTime
systime
    hash :: Text
hash = BlockHash -> Text
blockHashToHex (BlockHeader -> BlockHash
headerHash (BlockNode -> BlockHeader
nodeHeader BlockNode
bn))
    sep :: Text
sep = Text
" | "
    size :: Block -> Text
size = (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" bytes") (Text -> Text) -> (Block -> Text) -> Block -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (String -> Text) -> (Block -> String) -> Block -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> String) -> (Block -> Int) -> Block -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int
B.length (ByteString -> Int) -> (Block -> ByteString) -> Block -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> ByteString
forall a. Serialize a => a -> ByteString
encode