{-# 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 s :: 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 "height"
    Gauge
headersHeight           <- Text -> IO Gauge
g "headers"
    Gauge
storePendingTxs         <- Text -> IO Gauge
g "pending_txs"
    Gauge
storePeersConnected     <- Text -> IO Gauge
g "peers_connected"
    Gauge
storeMempoolSize        <- Text -> IO Gauge
g "mempool_size"
    StoreMetrics -> IO StoreMetrics
forall (m :: * -> *) a. Monad m => a -> m a
return $WStoreMetrics :: Gauge -> Gauge -> Gauge -> Gauge -> Gauge -> StoreMetrics
StoreMetrics{..}
  where
    g :: Text -> IO Gauge
g x :: Text
x = Text -> Store -> IO Gauge
Metrics.createGauge   ("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
    Nothing -> () -> BlockT m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just m :: 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
        Nothing -> StoreMetrics -> Integer -> BlockT m ()
forall (m :: * -> *) a.
(MonadIO m, Integral a) =>
StoreMetrics -> a -> m ()
setit StoreMetrics
m 0
        Just bb :: 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
            Nothing -> StoreMetrics -> Integer -> BlockT m ()
forall (m :: * -> *) a.
(MonadIO m, Integral a) =>
StoreMetrics -> a -> m ()
setit StoreMetrics
m 0
            Just b :: 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 m :: StoreMetrics
m i :: 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
    Nothing -> () -> BlockT m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just m :: 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
    Nothing -> () -> BlockT m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just m :: 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
>>= \t :: 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
    Nothing -> () -> BlockT m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just m :: 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
    Nothing -> () -> BlockT m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just m :: 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 -> 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 f :: 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
$ \r :: 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 f :: 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 MonadIO 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 as :: [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 as :: [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 a :: 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 a :: 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 cfg :: BlockStoreConfig
cfg action :: 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 = $WBlockStore :: 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
$ \a :: 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 :: 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 txs :: t (a, TxHash)
txs = do
        $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
logInfoS) "BlockStore" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
            "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
<> " 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
$ \(_, th :: 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 txs :: [(a, TxHash)]
txs = do
        let (txs1 :: [(a, TxHash)]
txs1, txs2 :: [(a, TxHash)]
txs2) = Int -> [(a, TxHash)] -> ([(a, TxHash)], [(a, TxHash)])
forall a. Int -> [a] -> ([a], [a])
splitAt 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 e :: ImportException
e -> do
                    $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> ReaderT BlockStore m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logErrorS) "BlockStore" (Text -> ReaderT BlockStore m ())
-> Text -> ReaderT BlockStore m ()
forall a b. (a -> b) -> a -> b
$
                        "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 e :: ImportException
e -> do
                  $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> ReaderT BlockStore m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logErrorS) "BlockStore" (Text -> ReaderT BlockStore m ())
-> Text -> ReaderT BlockStore m ()
forall a b. (a -> b) -> a -> b
$
                      "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 :: 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
        Nothing -> do
            $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> ReaderT BlockStore m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logErrorS) "BlockStore" "Block database uninitialized"
            BlockException -> BlockT m Bool
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO BlockException
Uninitialized
        Just bb :: 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 f :: 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

mempool :: (MonadUnliftIO m, MonadLoggerIO m) => Peer -> BlockT m ()
mempool :: Peer -> BlockT m ()
mempool p :: 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
$ 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
>>= \s :: 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
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> BlockT m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logDebugS) "BlockStore" (Text -> BlockT m ()) -> Text -> BlockT m ()
forall a b. (a -> b) -> a -> b
$
            "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
peer block :: 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
        True -> () -> MaybeT (ReaderT BlockStore m) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        False -> do
            $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> MaybeT (ReaderT BlockStore m) ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logErrorS) "BlockStore" (Text -> MaybeT (ReaderT BlockStore m) ())
-> Text -> MaybeT (ReaderT BlockStore m) ()
forall a b. (a -> b) -> a -> b
$
                "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
<> " sent me a block: "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> BlockHash -> Text
blockHashToHex BlockHash
blockhash
            String -> PeerException
PeerMisbehaving "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 b :: BlockNode
b -> BlockNode -> MaybeT (ReaderT BlockStore m) BlockNode
forall (m :: * -> *) a. Monad m => a -> m a
return BlockNode
b
        Nothing -> do
            $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> MaybeT (ReaderT BlockStore m) ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logErrorS) "BlockStore" (Text -> MaybeT (ReaderT BlockStore m) ())
-> Text -> MaybeT (ReaderT BlockStore m) ()
forall a b. (a -> b) -> a -> b
$
                "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
<> " sent unknown block: "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> BlockHash -> Text
blockHashToHex BlockHash
blockhash
            String -> PeerException
PeerMisbehaving "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
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> MaybeT (ReaderT BlockStore m) ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logDebugS) "BlockStore" (Text -> MaybeT (ReaderT BlockStore m) ())
-> Text -> MaybeT (ReaderT BlockStore m) ()
forall a b. (a -> b) -> a -> b
$
        "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
<> " 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 e :: 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 node :: BlockNode
node = do
        $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> BlockT m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logInfoS) "BlockStore" (Text -> BlockT m ()) -> Text -> BlockT m ()
forall a b. (a -> b) -> a -> b
$
            "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
            False -> BlockT m ()
forall (m :: * -> *). MonadLoggerIO m => BlockT m ()
syncMe
            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 e :: a
e = do
        $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logErrorS) "BlockStore" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
            "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
<> " 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
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 hs :: [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
>>= \box :: 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
        Nothing -> Maybe Syncing
forall a. Maybe a
Nothing
        Just x :: 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
        Nothing -> [BlockHash] -> m [BlockHash]
forall (m :: * -> *) a. Monad m => a -> m a
return []
        Just x :: 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 hs :: [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
>>= \box :: 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
        Nothing -> Maybe Syncing
forall a. Maybe a
Nothing
        Just x :: 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 h :: 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
        Nothing -> Maybe Syncing
forall a. Maybe a
Nothing
        Just x :: 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 p :: 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
        Nothing -> Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Just p' :: 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 =
    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 p :: Peer
p hs :: [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 [(1 :: Int) ..] [BlockHash]
hs) (((Int, BlockHash) -> BlockT m ()) -> BlockT m ())
-> ((Int, BlockHash) -> BlockT m ()) -> BlockT m ()
forall a b. (a -> b) -> a -> b
$ \(i :: Int
i, h :: BlockHash
h) ->
        $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> BlockT m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logErrorS) "BlockStore" (Text -> BlockT m ()) -> Text -> BlockT m ()
forall a b. (a -> b) -> a -> b
$
            "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
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
forall a. Semigroup a => a -> a -> a
<> BlockHash -> Text
blockHashToHex BlockHash
h
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " 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 "Did not find requested block(s)") Peer
p

processTx :: MonadLoggerIO m => Peer -> Tx -> BlockT m ()
processTx :: Peer -> Tx -> BlockT m ()
processTx p :: Peer
p tx :: 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
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> BlockT m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logDebugS) "BlockManager" (Text -> BlockT m ()) -> Text -> BlockT m ()
forall a b. (a -> b) -> a -> b
$
        "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
<> " 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
$ \p :: PendingTx
p ->
        UTCTime
now UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` PendingTx -> UTCTime
pendingTxTime PendingTx
p NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
> 600

addPendingTx :: MonadIO m => PendingTx -> BlockT m ()
addPendingTx :: PendingTx -> BlockT m ()
addPendingTx p :: 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 th :: 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 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 th :: 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 i :: 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
>>= \box :: 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 (selected :: [PendingTx]
selected, rest :: 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 pend :: 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 m :: 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 block_read :: BlockStore
block_read th :: 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 p :: 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
$ \p :: 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
            True  -> Maybe PendingTx -> m (Maybe PendingTx)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe PendingTx
forall a. Maybe a
Nothing
            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 th :: 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
        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
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 p :: PendingTx
p unspent :: 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 p :: 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 block_read :: BlockStore
block_read time :: UTCTime
time tx :: Tx
tx = do
    $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> WriterT m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logDebugS) "BlockStore" (Text -> WriterT m ()) -> Text -> WriterT m ()
forall a b. (a -> b) -> a -> b
$
        "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
<> ": 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)
        $WPendingTx :: UTCTime -> Tx -> HashSet TxHash -> PendingTx
PendingTx { pendingTxTime :: UTCTime
pendingTxTime = UTCTime
time
                  , pendingTx :: Tx
pendingTx = Tx
tx
                  , pendingDeps :: HashSet TxHash
pendingDeps = HashSet TxHash
missing_txs
                  }
  where
    prev_set :: HashSet OutPoint
prev_set = [OutPoint] -> HashSet OutPoint
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HashSet.fromList [OutPoint]
prevs
    prevs :: [OutPoint]
prevs = (TxIn -> OutPoint) -> [TxIn] -> [OutPoint]
forall a b. (a -> b) -> [a] -> [b]
map TxIn -> OutPoint
prevOutput (Tx -> [TxIn]
txIn Tx
tx)

importMempoolTx
    :: (MonadLoggerIO m, MonadError ImportException m)
    => BlockStore
    -> UTCTime
    -> Tx
    -> WriterT m Bool
importMempoolTx :: BlockStore -> UTCTime -> Tx -> WriterT m Bool
importMempoolTx block_read :: BlockStore
block_read time :: UTCTime
time tx :: Tx
tx =
    WriterT m Bool
-> (ImportException -> WriterT m Bool) -> WriterT m Bool
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError WriterT m Bool
new_mempool_tx ImportException -> WriterT m Bool
forall (m :: * -> *).
MonadLoggerIO m =>
ImportException -> ReaderT Writer m Bool
handle_error
  where
    tx_hash :: TxHash
tx_hash = Tx -> TxHash
txHash Tx
tx
    handle_error :: ImportException -> ReaderT Writer m Bool
handle_error Orphan = do
        BlockStore -> UTCTime -> Tx -> WriterT m ()
forall (m :: * -> *).
MonadLoggerIO m =>
BlockStore -> UTCTime -> Tx -> WriterT m ()
newOrphanTx BlockStore
block_read UTCTime
time Tx
tx
        Bool -> ReaderT Writer m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    handle_error _ = Bool -> ReaderT Writer m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    seconds :: UnixTime
seconds = NominalDiffTime -> UnixTime
forall a b. (RealFrac a, Integral b) => a -> b
floor (UTCTime -> NominalDiffTime
utcTimeToPOSIXSeconds UTCTime
time)
    new_mempool_tx :: WriterT m Bool
new_mempool_tx =
        Tx -> UnixTime -> WriterT m Bool
forall (m :: * -> *). MonadImport m => Tx -> UnixTime -> m Bool
newMempoolTx Tx
tx UnixTime
seconds WriterT m Bool -> (Bool -> WriterT m Bool) -> WriterT m Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            True -> do
                $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> ReaderT Writer m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logInfoS) "BlockStore" (Text -> ReaderT Writer m ()) -> Text -> ReaderT Writer m ()
forall a b. (a -> b) -> a -> b
$
                    "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
<> ": OK"
                BlockStore -> TxHash -> ReaderT Writer m ()
forall (m :: * -> *). MonadIO m => BlockStore -> TxHash -> m ()
fulfillOrphans BlockStore
block_read TxHash
tx_hash
                Bool -> WriterT m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
            False -> do
                $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> ReaderT Writer m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logDebugS) "BlockStore" (Text -> ReaderT Writer m ()) -> Text -> ReaderT Writer m ()
forall a b. (a -> b) -> a -> b
$
                    "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
<> ": Already imported"
                Bool -> WriterT m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

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 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]
forall (m :: * -> *).
MonadLoggerIO m =>
BlockStore -> [PendingTx] -> ReaderT BlockStore m [TxHash]
import_txs BlockStore
block_read [PendingTx]
txs ReaderT BlockStore m [TxHash]
-> ([TxHash] -> BlockT m ()) -> BlockT m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [TxHash] -> BlockT m ()
success)
  where
    run_import :: BlockStore -> PendingTx -> ReaderT Writer m (Maybe TxHash)
run_import block_read :: BlockStore
block_read p :: PendingTx
p =
        BlockStore -> UTCTime -> Tx -> WriterT m Bool
forall (m :: * -> *).
(MonadLoggerIO m, MonadError ImportException m) =>
BlockStore -> UTCTime -> Tx -> WriterT m Bool
importMempoolTx
            BlockStore
block_read
            (PendingTx -> UTCTime
pendingTxTime PendingTx
p)
            (PendingTx -> Tx
pendingTx PendingTx
p) WriterT m Bool
-> (Bool -> ReaderT Writer m (Maybe TxHash))
-> ReaderT Writer m (Maybe TxHash)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                True  -> Maybe TxHash -> ReaderT Writer m (Maybe TxHash)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe TxHash -> ReaderT Writer m (Maybe TxHash))
-> Maybe TxHash -> ReaderT Writer m (Maybe TxHash)
forall a b. (a -> b) -> a -> b
$ TxHash -> Maybe TxHash
forall a. a -> Maybe a
Just (Tx -> TxHash
txHash (PendingTx -> Tx
pendingTx PendingTx
p))
                False -> Maybe TxHash -> ReaderT Writer m (Maybe TxHash)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe TxHash
forall a. Maybe a
Nothing
    import_txs :: BlockStore -> [PendingTx] -> ReaderT BlockStore m [TxHash]
import_txs block_read :: BlockStore
block_read txs :: [PendingTx]
txs =
        let r :: ReaderT Writer (ExceptT ImportException m) [Maybe TxHash]
r = (PendingTx
 -> ReaderT Writer (ExceptT ImportException m) (Maybe TxHash))
-> [PendingTx]
-> ReaderT Writer (ExceptT ImportException m) [Maybe 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)
forall (m :: * -> *).
(MonadLoggerIO m, MonadError ImportException m) =>
BlockStore -> PendingTx -> ReaderT Writer m (Maybe TxHash)
run_import BlockStore
block_read) [PendingTx]
txs
         in ReaderT Writer (ExceptT ImportException m) [Maybe TxHash]
-> BlockT m (Either ImportException [Maybe TxHash])
forall (m :: * -> *) a.
MonadLoggerIO m =>
WriterT (ExceptT ImportException m) a
-> BlockT m (Either ImportException a)
runImport ReaderT Writer (ExceptT ImportException m) [Maybe TxHash]
r BlockT m (Either ImportException [Maybe TxHash])
-> (Either ImportException [Maybe TxHash]
    -> ReaderT BlockStore m [TxHash])
-> ReaderT BlockStore m [TxHash]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Left e :: 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] -> ReaderT BlockStore m [TxHash]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [TxHash] -> ReaderT BlockStore m [TxHash]
forall (m :: * -> *) a. Monad m => a -> m a
return []
            Right ms :: [Maybe TxHash]
ms -> [TxHash] -> ReaderT BlockStore m [TxHash]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Maybe TxHash] -> [TxHash]
forall a. [Maybe a] -> [a]
catMaybes [Maybe TxHash]
ms)
    report_error :: e -> m b
report_error e :: e
e = do
        $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logErrorS) "BlockImport" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
            "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] -> BlockT m ()
success = (TxHash -> BlockT m ()) -> [TxHash] -> BlockT m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ TxHash -> BlockT m ()
forall (m :: * -> *).
(MonadReader BlockStore m, MonadIO m) =>
TxHash -> m ()
notify
    notify :: TxHash -> m ()
notify txid :: TxHash
txid = 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)
        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 p :: Peer
p hs :: [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
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> BlockT m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logDebugS) "BlockStore" (Text -> BlockT m ()) -> Text -> BlockT m ()
forall a b. (a -> b) -> a -> b
$
            "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
<> " 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 [(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 i :: a
i h :: 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
            True -> do
                $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> ReaderT BlockStore m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logDebugS) "BlockStore" (Text -> ReaderT BlockStore m ())
-> Text -> ReaderT BlockStore m ()
forall a b. (a -> b) -> a -> b
$
                    "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
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
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
forall a. Semigroup a => a -> a -> a
<> "Pending"
                Maybe TxHash -> ReaderT BlockStore m (Maybe TxHash)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe TxHash
forall a. Maybe a
Nothing
            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 _ -> do
                    $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> ReaderT BlockStore m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logDebugS) "BlockStore" (Text -> ReaderT BlockStore m ())
-> Text -> ReaderT BlockStore m ()
forall a b. (a -> b) -> a -> b
$
                        "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
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
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
forall a. Semigroup a => a -> a -> a
<> "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
                Nothing -> do
                    $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> ReaderT BlockStore m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logDebugS) "BlockStore" (Text -> ReaderT BlockStore m ())
-> Text -> ReaderT BlockStore m ()
forall a b. (a -> b) -> a -> b
$
                        "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
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
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
forall a. Semigroup a => a -> a -> a
<> "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 xs :: [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
        Nothing -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just _ -> 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
$ \x :: 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
        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
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> BlockT m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logErrorS) "BlockStore" (Text -> BlockT m ()) -> Text -> BlockT m ()
forall a b. (a -> b) -> a -> b
$
                    "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
>>= \x :: 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
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> BlockT m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logWarnS) "BlockStore" (Text -> BlockT m ()) -> Text -> BlockT m ()
forall a b. (a -> b) -> a -> b
$
            "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 e :: ImportException
e -> do
                $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> BlockT m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logErrorS) "BlockStore" (Text -> BlockT m ()) -> Text -> BlockT m ()
forall a b. (a -> b) -> a -> b
$
                    "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
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 b :: BlockHash
b -> BlockHash -> ReaderT BlockStore m BlockHash
forall (m :: * -> *) a. Monad m => a -> m a
return BlockHash
b
        Nothing -> do
            $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> ReaderT BlockStore m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logErrorS) "BlockStore" "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 x :: BlockNode
x -> BlockNode -> BlockT m BlockNode
forall (m :: * -> *) a. Monad m => a -> m a
return BlockNode
x
        Nothing -> do
            $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> ReaderT BlockStore m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logErrorS) "BlockStore" (Text -> ReaderT BlockStore m ())
-> Text -> ReaderT BlockStore m ()
forall a b. (a -> b) -> a -> b
$
                "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 b :: BlockHash
b -> BlockHash -> ReaderT BlockStore m BlockHash
forall (m :: * -> *) a. Monad m => a -> m a
return BlockHash
b
            Nothing -> do
                $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> ReaderT BlockStore m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logErrorS) "BlockStore" "No best block set"
                BlockException -> ReaderT BlockStore m BlockHash
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO BlockException
Uninitialized
        hs :: [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 x :: BlockNode
x -> BlockNode -> BlockT m BlockNode
forall (m :: * -> *) a. Monad m => a -> m a
return BlockNode
x
        Nothing -> do
            $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> ReaderT BlockStore m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logErrorS) "BlockStore" (Text -> ReaderT BlockStore m ())
-> Text -> ReaderT BlockStore m ()
forall a b. (a -> b) -> a -> b
$
                "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
        True -> Maybe Peer -> BlockT m (Maybe Peer)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Peer
forall a. Maybe a
Nothing
        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
            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 }
                | 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
        Nothing -> () -> BlockT m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just p :: 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
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> BlockT m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logDebugS) "BlockStore" (Text -> BlockT m ()) -> Text -> BlockT m ()
forall a b. (a -> b) -> a -> b
$
                    "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
<> " 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 bns :: [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 bb :: BlockNode
bb bh :: 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
+ 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 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 bb :: BlockNode
bb bh :: 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
+ 501)
            (BlockNode -> BlockHeight
nodeHeight BlockNode
bh)
    top :: BlockHeight -> BlockNode -> m BlockNode
top sh :: BlockHeight
sh bh :: 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 height :: BlockHeight
height target :: 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 ancestor :: BlockNode
ancestor -> BlockNode -> m BlockNode
forall (m :: * -> *) a. Monad m => a -> m a
return BlockNode
ancestor
        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
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logErrorS) "BlockStore" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
                "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
<> " 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 p :: 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
        _                                           -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    reset_it :: TVar (Maybe a) -> m ()
reset_it box :: 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
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logDebugS) "BlockStore" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ "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 p :: 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 _  -> Bool -> BlockT m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        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
            False -> Bool -> BlockT m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
            True -> do
                $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> ReaderT BlockStore m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logDebugS) "BlockStore" (Text -> ReaderT BlockStore m ())
-> Text -> ReaderT BlockStore m ()
forall a b. (a -> b) -> a -> b
$
                    "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 $WSyncing :: 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
        True -> () -> BlockT m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        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 _  -> () -> BlockT m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            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 (p :: Peer
p : ps :: [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
            False -> [Peer] -> ReaderT BlockStore m ()
recurse [Peer]
ps
            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 p :: 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
        True -> Peer -> BlockT m ()
forall (m :: * -> *).
(MonadUnliftIO m, MonadLoggerIO m) =>
Peer -> BlockT m ()
mempool Peer
p
        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
            False -> () -> BlockT m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            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
        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 _) =
    BlockT m ()
forall (m :: * -> *). MonadLoggerIO m => BlockT m ()
trySyncing

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

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

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

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

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

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

processBlockStoreMessage (BlockPing r :: 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 mbox :: 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
$
            CharPos -> IO Int
forall a (m :: * -> *). (Random a, MonadIO m) => (a, a) -> m a
randomRIO (  100 Int -> Int -> Int
forall a. Num a => a -> a -> a
* 1000
                      , 1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* 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
peer store :: 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
peer store :: 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 node :: BlockNode
node store :: 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
peer block :: Block
block store :: 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
peer blocks :: [BlockHash]
blocks store :: 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
peer tx :: Tx
tx store :: 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
peer txhashes :: [TxHash]
txhashes store :: 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
peer store :: 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
peer store :: 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 node :: BlockNode
node store :: 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
peer block :: Block
block store :: 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
peer blocks :: [BlockHash]
blocks store :: 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
peer tx :: Tx
tx store :: 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
peer txhashes :: [TxHash]
txhashes store :: 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 {..} = 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 bn :: BlockNode
bn mblock :: Maybe Block
mblock = case Maybe Block
mblock of
    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
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 "%H:%M"))
                UTCTime
systime
    hash :: Text
hash = BlockHash -> Text
blockHashToHex (BlockHeader -> BlockHash
headerHash (BlockNode -> BlockHeader
nodeHeader BlockNode
bn))
    sep :: Text
sep = " | "
    size :: Block -> Text
size = (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " 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