diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -62,6 +62,7 @@ , configRedisMin :: !Int , configRedisMax :: !Integer , configWipeMempool :: !Bool + , configNoMempool :: !Bool , configPeerTimeout :: !Int , configPeerMaxLife :: !Int , configMaxPeers :: !Int @@ -86,6 +87,7 @@ , configRedisMin = defRedisMin , configRedisMax = defRedisMax , configWipeMempool = defWipeMempool + , configNoMempool = defNoMempool , configPeerTimeout = defPeerTimeout , configPeerMaxLife = defPeerMaxLife , configMaxPeers = defMaxPeers @@ -189,6 +191,11 @@ defEnv "WIPE_MEMPOOL" False parseBool {-# NOINLINE defWipeMempool #-} +defNoMempool :: Bool +defNoMempool = unsafePerformIO $ + defEnv "NO_MEMPOOL" False parseBool +{-# NOINLINE defNoMempool #-} + defRedisURL :: String defRedisURL = unsafePerformIO $ defEnv "REDIS" "" pure @@ -277,6 +284,7 @@ option auto $ metavar "INT" <> long "max-peers" + <> help "Do not connect to more than this many peers" <> showDefault <> value (configMaxPeers def) configVersion <- @@ -393,6 +401,10 @@ <> help "Maximum number of keys in Redis xpub cache" <> showDefault <> value (configRedisMax def) + configNoMempool <- + flag (configNoMempool def) True $ + long "no-mempool" + <> help "Do not index new mempool transactions" configWipeMempool <- flag (configWipeMempool def) True $ long "wipe-mempool" @@ -472,6 +484,7 @@ , configPeerMaxLife = peerlife , configMaxPeers = maxpeers , configMaxDiff = maxdiff + , configNoMempool = nomem } = runStderrLoggingT . filterLogger l $ do $(logInfoS) "Main" $ @@ -494,6 +507,7 @@ , storeConfCacheMin = cachemin , storeConfMaxKeys = redismax , storeConfWipeMempool = wipemempool + , storeConfNoMempool = nomem , storeConfPeerTimeout = fromIntegral peertimeout , storeConfPeerMaxLife = fromIntegral peerlife , storeConfConnect = withConnection @@ -510,6 +524,7 @@ , webMaxPending = pend , webVersion = version , webMaxDiff = maxdiff + , webNoMempool = nomem } where l _ lvl diff --git a/haskoin-store.cabal b/haskoin-store.cabal --- a/haskoin-store.cabal +++ b/haskoin-store.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: a3e1d274d97d15841ac32d9f355a41cae196b058822e0d107e4c5ddd928e27b3 +-- hash: 19e16f531b4684565261115fe5913e67ca2b6d20d45e90afe3e3beacd520f3c2 name: haskoin-store -version: 0.37.1 +version: 0.37.2 synopsis: Storage and index for Bitcoin and Bitcoin Cash description: Please see the README on GitHub at category: Bitcoin, Finance, Network @@ -53,7 +53,7 @@ , hashable >=1.3.0.0 , haskoin-core >=0.13.6 , haskoin-node >=0.14.1 - , haskoin-store-data ==0.37.1 + , haskoin-store-data ==0.37.2 , hedis >=0.12.13 , http-types >=0.12.3 , monad-logger >=0.3.32 @@ -96,7 +96,7 @@ , haskoin-core >=0.13.6 , haskoin-node >=0.14.1 , haskoin-store - , haskoin-store-data ==0.37.1 + , haskoin-store-data ==0.37.2 , monad-logger >=0.3.32 , mtl >=2.2.2 , nqe >=0.6.1 @@ -135,8 +135,8 @@ , hashable >=1.3.0.0 , haskoin-core >=0.13.6 , haskoin-node >=0.14.1 - , haskoin-store ==0.37.1 - , haskoin-store-data ==0.37.1 + , haskoin-store ==0.37.2 + , haskoin-store-data ==0.37.2 , hedis >=0.12.13 , hspec >=2.7.1 , http-types >=0.12.3 diff --git a/src/Haskoin/Store/BlockStore.hs b/src/Haskoin/Store/BlockStore.hs --- a/src/Haskoin/Store/BlockStore.hs +++ b/src/Haskoin/Store/BlockStore.hs @@ -74,9 +74,8 @@ getPeers, killPeer, peerText, sendMessage, setBusy, setFree) import Haskoin.Store.Common -import Haskoin.Store.Data (TxData (..), TxRef (..), - Unspent (..)) -import Haskoin.Store.Database.Reader (DatabaseReader) +import Haskoin.Store.Data +import Haskoin.Store.Database.Reader import Haskoin.Store.Database.Writer import Haskoin.Store.Logic (ImportException (Orphan), deleteUnconfirmedTx, @@ -153,6 +152,8 @@ -- ^ RocksDB database handle , blockConfNet :: !Network -- ^ network constants + , blockConfNoMempool :: !Bool + -- ^ do not index new mempool transactions , blockConfWipeMempool :: !Bool -- ^ wipe mempool at start , blockConfPeerTimeout :: !NominalDiffTime @@ -235,9 +236,8 @@ del txs = do $(logInfoS) "BlockStore" $ "Deleting " <> cs (show (length txs)) <> " transactions" - forM_ txs $ \tx -> - deleteUnconfirmedTx False (txRefHash tx) - wipeit txs = do + forM_ txs $ \(_, th) -> deleteUnconfirmedTx False th + wipe_it txs = do let (txs1, txs2) = splitAt 1000 txs unless (null txs1) $ runImport (del txs1) >>= \case @@ -245,10 +245,10 @@ $(logErrorS) "BlockStore" $ "Could not wipe mempool: " <> cs (show e) throwIO e - Right () -> wipeit txs2 + Right () -> wipe_it txs2 wipe | blockConfWipeMempool cfg = - getMempool >>= wipeit + getMempool >>= wipe_it | otherwise = return () ini = runImport initBest >>= \case @@ -275,16 +275,22 @@ then clearSyncingState >> return True else return False +guardMempool :: Monad m => BlockT m () -> BlockT m () +guardMempool f = do + n <- asks (blockConfNoMempool . myConfig) + unless n f + +guardNotMempooled :: MonadIO m => BlockT m () -> BlockT m () +guardNotMempooled f = do + m <- readTVarIO =<< asks mempooled + unless m f + mempool :: MonadLoggerIO m => Peer -> BlockT m () -mempool p = do - mem <- readTVarIO =<< asks mempooled - if mem - then return () - else do - $(logDebugS) "BlockStore" $ - "Requesting mempool from peer: " <> peerText p - MMempool `sendMessage` p - atomically . (`writeTVar` True) =<< asks mempooled +mempool p = guardMempool $ guardNotMempooled $ do + $(logDebugS) "BlockStore" $ + "Requesting mempool from peer: " <> peerText p + MMempool `sendMessage` p + atomically . (`writeTVar` True) =<< asks mempooled processBlock :: MonadLoggerIO m => Peer -> Block -> BlockT m () processBlock peer block = void . runMaybeT $ do @@ -395,7 +401,7 @@ killPeer (PeerMisbehaving "Did not find requested block(s)") p processTx :: MonadLoggerIO m => Peer -> Tx -> BlockT m () -processTx p tx = do +processTx p tx = guardMempool $ do t <- liftIO getCurrentTime $(logDebugS) "BlockManager" $ "Received tx " <> txHashToHex (txHash tx) @@ -403,7 +409,7 @@ addPendingTx $ PendingTx t tx HashSet.empty pruneOrphans :: MonadIO m => BlockT m () -pruneOrphans = do +pruneOrphans = guardMempool $ do ts <- asks myTxs now <- liftIO getCurrentTime atomically . modifyTVar ts . HashMap.filter $ \p -> @@ -550,7 +556,7 @@ return False processMempool :: MonadLoggerIO m => BlockT m () -processMempool = do +processMempool = guardMempool $ do txs <- pendingTxs 2000 block_read <- ask unless (null txs) (import_txs block_read txs >>= success) @@ -581,7 +587,7 @@ => Peer -> [TxHash] -> BlockT m () -processTxs p hs = do +processTxs p hs = guardMempool $ do s <- isInSync when s $ do $(logDebugS) "BlockStore" $ @@ -652,7 +658,7 @@ killPeer PeerTimeout p pruneMempool :: MonadLoggerIO m => BlockT m () -pruneMempool = do +pruneMempool = guardMempool $ do s <- isInSync when s $ do now <- liftIO getCurrentTime diff --git a/src/Haskoin/Store/Cache.hs b/src/Haskoin/Store/Cache.hs --- a/src/Haskoin/Store/Cache.hs +++ b/src/Haskoin/Store/Cache.hs @@ -71,12 +71,7 @@ chainGetAncestor, chainGetBest, chainGetBlock) import Haskoin.Store.Common -import Haskoin.Store.Data (Balance (..), BlockData (..), - BlockRef (..), DeriveType (..), - Prev (..), TxData (..), TxRef (..), - Unspent (..), XPubBal (..), - XPubSpec (..), XPubUnspent (..), - nullBalance) +import Haskoin.Store.Data import NQE (Inbox, Mailbox, receive, send) import System.Random (randomIO) import UnliftIO (Exception, MonadIO, MonadUnliftIO, @@ -931,8 +926,8 @@ => CacheX m () syncMempoolC = void . withLock $ isCool >>= \cool -> when cool $ do - nodepool <- HashSet.fromList . map txRefHash <$> lift getMempool - cachepool <- HashSet.fromList . map txRefHash <$> cacheGetMempool + nodepool <- HashSet.fromList . map snd <$> lift getMempool + cachepool <- HashSet.fromList . map snd <$> cacheGetMempool txs <- mapM getit . HashSet.toList $ mappend (HashSet.difference nodepool cachepool) @@ -947,7 +942,7 @@ Nothing -> return (Left th) Just tx -> return (Right tx) -cacheGetMempool :: MonadLoggerIO m => CacheX m [TxRef] +cacheGetMempool :: MonadLoggerIO m => CacheX m [(UnixTime, TxHash)] cacheGetMempool = runRedis redisGetMempool cacheGetHead :: MonadLoggerIO m => CacheX m (Maybe BlockHash) @@ -1131,12 +1126,12 @@ x <- Redis.get bestBlockKey return $ (eitherToMaybe . decode =<<) <$> x -redisGetMempool :: (Applicative f, RedisCtx m f) => m (f [TxRef]) +redisGetMempool :: (Applicative f, RedisCtx m f) => m (f [(UnixTime, TxHash)]) redisGetMempool = do xs <- getFromSortedSet mempoolSetKey Nothing 0 0 return $ map (uncurry f) <$> xs where - f t s = TxRef {txRefBlock = scoreBlockRef s, txRefHash = t} + f t s = (memRefTime (scoreBlockRef s), t) xpubText :: (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) => XPubSpec -> CacheX m Text diff --git a/src/Haskoin/Store/Common.hs b/src/Haskoin/Store/Common.hs --- a/src/Haskoin/Store/Common.hs +++ b/src/Haskoin/Store/Common.hs @@ -105,7 +105,7 @@ getSpender :: OutPoint -> m (Maybe Spender) getBalance :: Address -> m (Maybe Balance) getUnspent :: OutPoint -> m (Maybe Unspent) - getMempool :: m [TxRef] + getMempool :: m [(UnixTime, TxHash)] class StoreReadBase m => StoreReadExtra m where getBalances :: [Address] -> m [Balance] @@ -208,17 +208,10 @@ getSpenders th = getActiveTxData th >>= \case Nothing -> return I.empty - Just td -> - I.fromList . catMaybes . zipWith f [0..] - <$> mapM getSpender (ops td) - + Just td -> I.fromList . catMaybes <$> + mapM get_spender [0 .. length (txOut (txData td)) - 1] where - f i m = (i, ) <$> m - ops td = - let tx = txData td - outs = txOut tx - op i _ = OutPoint th i - in zipWith op [0..] outs + get_spender i = fmap (i,) <$> getSpender (OutPoint th (fromIntegral i)) getActiveBlock :: StoreReadExtra m => BlockHash -> m (Maybe BlockData) getActiveBlock bh = getBlock bh >>= \case diff --git a/src/Haskoin/Store/Database/Reader.hs b/src/Haskoin/Store/Database/Reader.hs --- a/src/Haskoin/Store/Database/Reader.hs +++ b/src/Haskoin/Store/Database/Reader.hs @@ -31,17 +31,8 @@ import Haskoin (Address, BlockHash, BlockHeight, Network, OutPoint (..), TxHash) import Haskoin.Store.Common -import Haskoin.Store.Data (Balance, BlockData, - BlockRef (..), Spender, - TxData (..), TxRef (..), - Unspent (..)) -import Haskoin.Store.Database.Types (AddrOutKey (..), AddrTxKey (..), - BalKey (..), BestKey (..), - BlockKey (..), HeightKey (..), - MemKey (..), SpenderKey (..), - TxKey (..), UnspentKey (..), - VersionKey (..), toUnspent, - valToBalance, valToUnspent) +import Haskoin.Store.Data +import Haskoin.Store.Database.Types import UnliftIO (MonadIO, MonadUnliftIO, liftIO) type DatabaseReaderT = ReaderT DatabaseReader @@ -157,11 +148,9 @@ getBalanceDB a DatabaseReader{databaseHandle = db} = fmap (valToBalance a) <$> retrieveCF db (balanceCF db) (BalKey a) -getMempoolDB :: MonadIO m => DatabaseReader -> m [TxRef] +getMempoolDB :: MonadIO m => DatabaseReader -> m [(UnixTime, TxHash)] getMempoolDB DatabaseReader{databaseHandle = db} = - fmap f . fromMaybe [] <$> retrieve db MemKey - where - f (t, h) = TxRef {txRefBlock = MemRef t, txRefHash = h} + fromMaybe [] <$> retrieve db MemKey getAddressesTxsDB :: MonadIO m diff --git a/src/Haskoin/Store/Database/Types.hs b/src/Haskoin/Store/Database/Types.hs --- a/src/Haskoin/Store/Database/Types.hs +++ b/src/Haskoin/Store/Database/Types.hs @@ -239,6 +239,7 @@ guard . (== 0x01) =<< getWord8 BlockKey <$> get +instance Key BlockKey instance KeyValue BlockKey BlockData -- | Block height database key. diff --git a/src/Haskoin/Store/Database/Writer.hs b/src/Haskoin/Store/Database/Writer.hs --- a/src/Haskoin/Store/Database/Writer.hs +++ b/src/Haskoin/Store/Database/Writer.hs @@ -1,26 +1,20 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Haskoin.Store.Database.Writer (WriterT , runWriter) where -import Control.Applicative ((<|>)) -import Control.DeepSeq (NFData) import Control.Monad.Reader (ReaderT (..)) import qualified Control.Monad.Reader as R -import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) import qualified Data.ByteString.Short as B.Short -import Data.Hashable (Hashable) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as M import Data.List (sortOn) import Data.Ord (Down (..)) +import Data.Tuple (swap) import Database.RocksDB (BatchOp, DB) import Database.RocksDB.Query (deleteOp, deleteOpCF, insertOp, insertOpCF, writeBatch) -import GHC.Generics (Generic) import Haskoin (Address, BlockHash, BlockHeight, Network, OutPoint (..), TxHash, headerHash, txHash) @@ -32,59 +26,43 @@ liftIO, modifyTVar, newTVarIO, readTVarIO) -data Dirty a = Modified a | Deleted - deriving (Eq, Show, Generic, Hashable, NFData) - -instance Functor Dirty where - fmap _ Deleted = Deleted - fmap f (Modified a) = Modified (f a) - data Writer = Writer { getReader :: !DatabaseReader , getState :: !(TVar Memory) } type WriterT = ReaderT Writer instance MonadIO m => StoreReadBase (WriterT m) where - getNetwork = - R.ask >>= getNetworkI - getBestBlock = - R.ask >>= getBestBlockI - getBlocksAtHeight h = - R.ask >>= getBlocksAtHeightI h - getBlock b = - R.ask >>= getBlockI b - getTxData t = - R.ask >>= getTxDataI t - getSpender p = - R.ask >>= getSpenderI p - getUnspent a = - R.ask >>= getUnspentI a - getBalance a = - R.ask >>= getBalanceI a - getMempool = - R.ask >>= getMempoolI + getNetwork = getNetworkI + getBestBlock = getBestBlockI + getBlocksAtHeight = getBlocksAtHeightI + getBlock = getBlockI + getTxData = getTxDataI + getSpender = getSpenderI + getUnspent = getUnspentI + getBalance = getBalanceI + getMempool = getMempoolI data Memory = Memory { hNet - :: !Network + :: !(Maybe Network) , hBest - :: !(Maybe BlockHash) + :: !(Maybe (Maybe BlockHash)) , hBlock - :: !(HashMap BlockHash BlockData) + :: !(HashMap BlockHash (Maybe BlockData)) , hHeight :: !(HashMap BlockHeight [BlockHash]) , hTx - :: !(HashMap TxHash TxData) + :: !(HashMap TxHash (Maybe TxData)) , hSpender - :: !(HashMap OutPoint (Dirty Spender)) + :: !(HashMap OutPoint (Maybe Spender)) , hUnspent - :: !(HashMap OutPoint (Dirty UnspentVal)) + :: !(HashMap OutPoint (Maybe Unspent)) , hBalance - :: !(HashMap Address BalVal) + :: !(HashMap Address (Maybe Balance)) , hAddrTx - :: !(HashMap (Address, TxRef) (Dirty ())) + :: !(HashMap (Address, TxRef) (Maybe ())) , hAddrOut - :: !(HashMap (Address, BlockRef, OutPoint) (Dirty OutVal)) + :: !(HashMap (Address, BlockRef, OutPoint) (Maybe OutVal)) , hMempool :: !(HashMap TxHash UnixTime) } deriving (Eq, Show) @@ -151,23 +129,31 @@ liftIO . atomically . modifyTVar s $ deleteUnspentH p -runWriter - :: MonadIO m - => DatabaseReader - -> WriterT m a - -> m a -runWriter bdb@DatabaseReader{ databaseHandle = db - , databaseNetwork = net } f = do - (mem, best) <- runReaderT ((,) <$> getMempool <*> getBestBlock) bdb - hm <- newTVarIO (emptyMemory net best mem) - x <- R.runReaderT f Writer {getReader = bdb, getState = hm} +getLayered :: MonadIO m + => (Memory -> Maybe a) + -> DatabaseReaderT m a + -> WriterT m a +getLayered f g = + ReaderT $ \Writer { getReader = db, getState = tmem } -> + f <$> readTVarIO tmem >>= \case + Just x -> return x + Nothing -> runReaderT g db + +runWriter :: MonadIO m + => DatabaseReader + -> WriterT m a + -> m a +runWriter bdb@DatabaseReader{ databaseHandle = db } f = do + mem <- runReaderT getMempool bdb + hm <- newTVarIO (newMemory mem) + x <- R.runReaderT f Writer { getReader = bdb, getState = hm } ops <- hashMapOps db <$> readTVarIO hm writeBatch db ops return x hashMapOps :: DB -> Memory -> [BatchOp] hashMapOps db mem = - bestBlockOp db (hBest mem) <> + bestBlockOp (hBest mem) <> blockHashOps db (hBlock mem) <> blockHeightOps db (hHeight mem) <> txOps db (hTx mem) <> @@ -175,149 +161,116 @@ balOps db (hBalance mem) <> addrTxOps db (hAddrTx mem) <> addrOutOps db (hAddrOut mem) <> - mempoolOp db (hMempool mem) <> + mempoolOp (hMempool mem) <> unspentOps db (hUnspent mem) -bestBlockOp :: DB -> Maybe BlockHash -> [BatchOp] -bestBlockOp _ Nothing = [deleteOp BestKey] -bestBlockOp _ (Just b) = [insertOp BestKey b] +bestBlockOp :: Maybe (Maybe BlockHash) -> [BatchOp] +bestBlockOp Nothing = [] +bestBlockOp (Just Nothing) = [deleteOp BestKey] +bestBlockOp (Just (Just b)) = [insertOp BestKey b] -blockHashOps :: DB -> HashMap BlockHash BlockData -> [BatchOp] +blockHashOps :: DB -> HashMap BlockHash (Maybe BlockData) -> [BatchOp] blockHashOps db = map (uncurry f) . M.toList where - f = insertOpCF (blockCF db) . BlockKey + f k (Just d) = insertOpCF (blockCF db) (BlockKey k) d + f k Nothing = deleteOpCF (blockCF db) (BlockKey k) blockHeightOps :: DB -> HashMap BlockHeight [BlockHash] -> [BatchOp] blockHeightOps db = map (uncurry f) . M.toList where f = insertOpCF (heightCF db) . HeightKey -txOps :: DB -> HashMap TxHash TxData -> [BatchOp] +txOps :: DB -> HashMap TxHash (Maybe TxData) -> [BatchOp] txOps db = map (uncurry f) . M.toList where - f = insertOpCF (txCF db) . TxKey + f k (Just t) = insertOpCF (txCF db) (TxKey k) t + f k Nothing = deleteOpCF (txCF db) (TxKey k) -spenderOps :: DB -> HashMap OutPoint (Dirty Spender) -> [BatchOp] +spenderOps :: DB -> HashMap OutPoint (Maybe Spender) -> [BatchOp] spenderOps db = map (uncurry f) . M.toList where - f o (Modified s) = - insertOpCF (spenderCF db) (SpenderKey o) s - f o Deleted = - deleteOpCF (spenderCF db) (SpenderKey o) + f o (Just s) = insertOpCF (spenderCF db) (SpenderKey o) s + f o Nothing = deleteOpCF (spenderCF db) (SpenderKey o) -balOps :: DB -> HashMap Address BalVal -> [BatchOp] +balOps :: DB -> HashMap Address (Maybe Balance) -> [BatchOp] balOps db = map (uncurry f) . M.toList where - f = insertOpCF (balanceCF db) . BalKey + f a (Just b) = insertOpCF (balanceCF db) (BalKey a) (balanceToVal b) + f a Nothing = deleteOpCF (balanceCF db) (BalKey a) -addrTxOps :: DB -> HashMap (Address, TxRef) (Dirty ()) -> [BatchOp] +addrTxOps :: DB -> HashMap (Address, TxRef) (Maybe ()) -> [BatchOp] addrTxOps db = map (uncurry f) . M.toList where - f (a, t) (Modified ()) = insertOpCF (addrTxCF db) (AddrTxKey a t) () - f (a, t) Deleted = deleteOpCF (addrTxCF db) (AddrTxKey a t) + f (a, t) (Just ()) = insertOpCF (addrTxCF db) (AddrTxKey a t) () + f (a, t) Nothing = deleteOpCF (addrTxCF db) (AddrTxKey a t) addrOutOps :: DB - -> HashMap (Address, BlockRef, OutPoint) (Dirty OutVal) + -> HashMap (Address, BlockRef, OutPoint) (Maybe OutVal) -> [BatchOp] addrOutOps db = map (uncurry f) . M.toList where - f (a, b, p) (Modified l) = - insertOpCF (addrOutCF db) - ( AddrOutKey { addrOutKeyA = a - , addrOutKeyB = b - , addrOutKeyP = p - } - ) l - f (a, b, p) Deleted = - deleteOpCF (addrOutCF db) - AddrOutKey { addrOutKeyA = a - , addrOutKeyB = b - , addrOutKeyP = p - } + f (a, b, p) (Just l) = + insertOpCF + (addrOutCF db) + (AddrOutKey { addrOutKeyA = a + , addrOutKeyB = b + , addrOutKeyP = p + } + ) + l + f (a, b, p) Nothing = + deleteOpCF + (addrOutCF db) + AddrOutKey { addrOutKeyA = a + , addrOutKeyB = b + , addrOutKeyP = p + } -mempoolOp :: DB -> HashMap TxHash UnixTime -> [BatchOp] -mempoolOp _ = (: []) - . insertOp MemKey - . sortOn Down - . map (\(h, t) -> (t, h)) - . M.toList +mempoolOp :: HashMap TxHash UnixTime -> [BatchOp] +mempoolOp = return . insertOp MemKey . sortOn Down . map swap . M.toList -unspentOps :: DB -> HashMap OutPoint (Dirty UnspentVal) -> [BatchOp] +unspentOps :: DB -> HashMap OutPoint (Maybe Unspent) -> [BatchOp] unspentOps db = map (uncurry f) . M.toList where - f p (Modified u) = - insertOpCF (unspentCF db) (UnspentKey p) u - f p Deleted = + f p (Just u) = + insertOpCF (unspentCF db) (UnspentKey p) (snd (unspentToVal u)) + f p Nothing = deleteOpCF (unspentCF db) (UnspentKey p) -getNetworkI :: MonadIO m => Writer -> m Network -getNetworkI Writer {getState = hm} = - hNet <$> readTVarIO hm +getNetworkI :: MonadIO m => WriterT m Network +getNetworkI = getLayered hNet getNetwork -getBestBlockI :: MonadIO m => Writer -> m (Maybe BlockHash) -getBestBlockI Writer {getState = hm} = - getBestBlockH <$> readTVarIO hm +getBestBlockI :: MonadIO m => WriterT m (Maybe BlockHash) +getBestBlockI = getLayered getBestBlockH getBestBlock -getBlocksAtHeightI :: MonadIO m - => BlockHeight - -> Writer - -> m [BlockHash] -getBlocksAtHeightI bh Writer {getState = hm, getReader = db} = - getBlocksAtHeightH bh <$> readTVarIO hm >>= \case - Just bs -> return bs - Nothing -> runReaderT (getBlocksAtHeight bh) db +getBlocksAtHeightI :: MonadIO m => BlockHeight -> WriterT m [BlockHash] +getBlocksAtHeightI bh = + getLayered (getBlocksAtHeightH bh) (getBlocksAtHeight bh) -getBlockI :: MonadIO m - => BlockHash - -> Writer - -> m (Maybe BlockData) -getBlockI bh Writer {getReader = db, getState = hm} = - runMaybeT $ MaybeT f <|> MaybeT g - where - f = getBlockH bh <$> readTVarIO hm - g = runReaderT (getBlock bh) db +getBlockI :: MonadIO m => BlockHash -> WriterT m (Maybe BlockData) +getBlockI bh = getLayered (getBlockH bh) (getBlock bh) -getTxDataI :: MonadIO m - => TxHash - -> Writer - -> m (Maybe TxData) -getTxDataI th Writer {getReader = db, getState = hm} = - runMaybeT $ MaybeT f <|> MaybeT g - where - f = getTxDataH th <$> readTVarIO hm - g = runReaderT (getTxData th) db +getTxDataI :: MonadIO m => TxHash -> WriterT m (Maybe TxData) +getTxDataI th = getLayered (getTxDataH th) (getTxData th) -getSpenderI :: MonadIO m => OutPoint -> Writer -> m (Maybe Spender) -getSpenderI op Writer {getReader = db, getState = hm} = - getSpenderH op <$> readTVarIO hm >>= \case - Just (Modified s) -> return (Just s) - Just Deleted -> return Nothing - Nothing -> runReaderT (getSpender op) db +getSpenderI :: MonadIO m => OutPoint -> WriterT m (Maybe Spender) +getSpenderI op = getLayered (getSpenderH op) (getSpender op) -getBalanceI :: MonadIO m => Address -> Writer -> m (Maybe Balance) -getBalanceI a Writer {getReader = db, getState = hm} = - getBalanceH a <$> readTVarIO hm >>= \case - Just b -> return $ Just (valToBalance a b) - Nothing -> runReaderT (getBalance a) db +getBalanceI :: MonadIO m => Address -> WriterT m (Maybe Balance) +getBalanceI a = getLayered (getBalanceH a) (getBalance a) -getUnspentI :: MonadIO m - => OutPoint - -> Writer - -> m (Maybe Unspent) -getUnspentI op Writer {getReader = db, getState = hm} = - getUnspentH op <$> readTVarIO hm >>= \case - Just (Modified u) -> return (Just (valToUnspent op u)) - Just Deleted -> return Nothing - Nothing -> runReaderT (getUnspent op) db +getUnspentI :: MonadIO m => OutPoint -> WriterT m (Maybe Unspent) +getUnspentI op = getLayered (getUnspentH op) (getUnspent op) -getMempoolI :: MonadIO m => Writer -> m [TxRef] -getMempoolI Writer {getState = hm} = - getMempoolH <$> readTVarIO hm +getMempoolI :: MonadIO m => WriterT m [(UnixTime, TxHash)] +getMempoolI = + ReaderT $ \Writer { getState = tmem } -> + getMempoolH <$> readTVarIO tmem -emptyMemory :: Network -> Maybe BlockHash -> [TxRef] -> Memory -emptyMemory net best mem = - Memory { hNet = net - , hBest = best +newMemory :: [(UnixTime, TxHash)] -> Memory +newMemory mem = + Memory { hNet = Nothing + , hBest = Nothing , hBlock = M.empty , hHeight = M.empty , hTx = M.empty @@ -326,38 +279,38 @@ , hBalance = M.empty , hAddrTx = M.empty , hAddrOut = M.empty - , hMempool = M.fromList $ map (\(TxRef (MemRef t) h) -> (h, t)) mem + , hMempool = M.fromList (map swap mem) } -getBestBlockH :: Memory -> Maybe BlockHash +getBestBlockH :: Memory -> Maybe (Maybe BlockHash) getBestBlockH = hBest getBlocksAtHeightH :: BlockHeight -> Memory -> Maybe [BlockHash] getBlocksAtHeightH h = M.lookup h . hHeight -getBlockH :: BlockHash -> Memory -> Maybe BlockData +getBlockH :: BlockHash -> Memory -> Maybe (Maybe BlockData) getBlockH h = M.lookup h . hBlock -getTxDataH :: TxHash -> Memory -> Maybe TxData +getTxDataH :: TxHash -> Memory -> Maybe (Maybe TxData) getTxDataH t = M.lookup t . hTx -getSpenderH :: OutPoint -> Memory -> Maybe (Dirty Spender) +getSpenderH :: OutPoint -> Memory -> Maybe (Maybe Spender) getSpenderH op db = M.lookup op (hSpender db) -getBalanceH :: Address -> Memory -> Maybe BalVal +getBalanceH :: Address -> Memory -> Maybe (Maybe Balance) getBalanceH a = M.lookup a . hBalance -getMempoolH :: Memory -> [TxRef] -getMempoolH = sortOn Down . map (\(h, t) -> TxRef (MemRef t) h) . M.toList . hMempool +getMempoolH :: Memory -> [(UnixTime, TxHash)] +getMempoolH = sortOn Down . map swap . M.toList . hMempool setBestH :: BlockHash -> Memory -> Memory -setBestH h db = db {hBest = Just h} +setBestH h db = db {hBest = Just (Just h)} insertBlockH :: BlockData -> Memory -> Memory insertBlockH bd db = db { hBlock = M.insert (headerHash (blockDataHeader bd)) - bd + (Just bd) (hBlock db) } @@ -367,41 +320,40 @@ insertTxH :: TxData -> Memory -> Memory insertTxH tx db = - db {hTx = M.insert (txHash (txData tx)) tx (hTx db)} + db {hTx = M.insert (txHash (txData tx)) (Just tx) (hTx db)} insertSpenderH :: OutPoint -> Spender -> Memory -> Memory insertSpenderH op s db = - db { hSpender = M.insert op (Modified s) (hSpender db) } + db { hSpender = M.insert op (Just s) (hSpender db) } deleteSpenderH :: OutPoint -> Memory -> Memory deleteSpenderH op db = - db { hSpender = M.insert op Deleted (hSpender db) } + db { hSpender = M.insert op Nothing (hSpender db) } setBalanceH :: Balance -> Memory -> Memory setBalanceH bal db = - db {hBalance = M.insert (balanceAddress bal) b (hBalance db)} - where - b = balanceToVal bal + db {hBalance = M.insert (balanceAddress bal) (Just bal) (hBalance db)} insertAddrTxH :: Address -> TxRef -> Memory -> Memory insertAddrTxH a tr db = - db { hAddrTx = M.insert (a, tr) (Modified ()) (hAddrTx db) } + db { hAddrTx = M.insert (a, tr) (Just ()) (hAddrTx db) } deleteAddrTxH :: Address -> TxRef -> Memory -> Memory deleteAddrTxH a tr db = - db { hAddrTx = M.insert (a, tr) Deleted (hAddrTx db) } + db { hAddrTx = M.insert (a, tr) Nothing (hAddrTx db) } insertAddrUnspentH :: Address -> Unspent -> Memory -> Memory insertAddrUnspentH a u db = let k = (a, unspentBlock u, unspentPoint u) v = OutVal { outValAmount = unspentAmount u - , outValScript = B.Short.fromShort (unspentScript u) } - in db { hAddrOut = M.insert k (Modified v) (hAddrOut db) } + , outValScript = B.Short.fromShort (unspentScript u) + } + in db { hAddrOut = M.insert k (Just v) (hAddrOut db) } deleteAddrUnspentH :: Address -> Unspent -> Memory -> Memory deleteAddrUnspentH a u db = let k = (a, unspentBlock u, unspentPoint u) - in db { hAddrOut = M.insert k Deleted (hAddrOut db) } + in db { hAddrOut = M.insert k Nothing (hAddrOut db) } addToMempoolH :: TxHash -> UnixTime -> Memory -> Memory addToMempoolH h t db = @@ -411,14 +363,14 @@ deleteFromMempoolH h db = db { hMempool = M.delete h (hMempool db) } -getUnspentH :: OutPoint -> Memory -> Maybe (Dirty UnspentVal) +getUnspentH :: OutPoint -> Memory -> Maybe (Maybe Unspent) getUnspentH op db = M.lookup op (hUnspent db) insertUnspentH :: Unspent -> Memory -> Memory insertUnspentH u db = - let (k, v) = unspentToVal u - in db { hUnspent = M.insert k (Modified v) (hUnspent db) } + let k = fst (unspentToVal u) + in db { hUnspent = M.insert k (Just u) (hUnspent db) } deleteUnspentH :: OutPoint -> Memory -> Memory deleteUnspentH op db = - db { hUnspent = M.insert op Deleted (hUnspent db) } + db { hUnspent = M.insert op Nothing (hUnspent db) } diff --git a/src/Haskoin/Store/Logic.hs b/src/Haskoin/Store/Logic.hs --- a/src/Haskoin/Store/Logic.hs +++ b/src/Haskoin/Store/Logic.hs @@ -16,7 +16,7 @@ , deleteUnconfirmedTx ) where -import Control.Monad (forM_, guard, unless, void, when, +import Control.Monad (forM, forM_, guard, unless, void, when, zipWithM_) import Control.Monad.Except (MonadError, throwError) import Control.Monad.Logger (MonadLoggerIO (..), logDebugS, @@ -93,9 +93,7 @@ getOldMempool :: StoreReadBase m => UnixTime -> m [TxHash] getOldMempool now = - map txRefHash . filter f <$> getMempool - where - f = (< now - 3600 * 72) . memRefTime . txRefBlock + map snd . filter ((< now - 3600 * 72) . fst) <$> getMempool newMempoolTx :: MonadImport m => Tx -> UnixTime -> m Bool newMempoolTx tx w = @@ -264,8 +262,8 @@ getUnspentOutputs :: StoreReadBase m => Tx -> m [Maybe Unspent] getUnspentOutputs tx = mapM getUnspent (prevOuts tx) -prepareTxData :: Bool -> BlockRef -> Word64 -> [Unspent] -> Tx -> TxData -prepareTxData rbf br tt us tx = +prepareTxData :: Bool -> BlockRef -> Word64 -> Tx -> [Unspent] -> TxData +prepareTxData rbf br tt tx us = TxData { txDataBlock = br , txData = tx , txDataPrevs = ps @@ -275,7 +273,7 @@ } where mkprv u = Prev (B.Short.fromShort (unspentScript u)) (unspentAmount u) - ps = I.fromList $ zip [0 ..] $ if isCoinbase tx then [] else map mkprv us + ps = I.fromList $ zip [0 ..] $ map mkprv us importTx :: MonadImport m @@ -285,15 +283,16 @@ -> Tx -> m () importTx br tt rbf tx = do - us <- getUnspentOutputs tx - when (any isNothing us && not (isCoinbase tx)) $ do - $(logErrorS) "BlockStore" $ - "Attempted to import a tx missing UTXO: " - <> txHashToHex (txHash tx) - throwError Orphan - let us' = catMaybes us - td = prepareTxData rbf br tt us' tx - commitAddTx us' td + mus <- getUnspentOutputs tx + us <- forM mus $ \case + Nothing -> do + $(logErrorS) "BlockStore" $ + "Attempted to import a tx missing UTXO: " + <> txHashToHex (txHash tx) + throwError Orphan + Just u -> return u + let td = prepareTxData rbf br tt tx us + commitAddTx td unConfirmTx :: MonadImport m => TxData -> m () unConfirmTx t = confTx t Nothing @@ -316,8 +315,12 @@ => OutPoint -> TxOut -> BlockRef -> BlockRef -> m () adjustAddressOutput op o old new = do let pk = scriptOutput o - u <- getUnspent op - when (isJust u) $ replace_unspent pk + getUnspent op >>= \case + Nothing -> return () + Just u -> do + unless (unspentBlock u == old) $ + error $ "Existing unspent block bad for output: " <> show op + replace_unspent pk where replace_unspent pk = do let ma = eitherToMaybe (scriptToAddressBS pk) @@ -360,12 +363,12 @@ let op = OutPoint (txHash (txData t)) n adjustAddressOutput op o old new rbf <- isRBF new (txData t) - insertTx (td rbf) - updateMempool (td rbf) + let td = t { txDataBlock = new, txDataRBF = rbf } + insertTx td + updateMempool td where new = fromMaybe (MemRef (txDataTime t)) mbr old = txDataBlock t - td rbf = t { txDataBlock = new, txDataRBF = rbf} freeOutputs :: MonadImport m @@ -379,9 +382,9 @@ unless (outPointHash op `S.member` ths) $ getUnspent op >>= \u -> when (isNothing u) $ getSpender op >>= \case - Just Spender { spenderHash = h } - | h == txHash tx -> return () - | otherwise -> deleteTx memonly rbfcheck h + Just Spender { spenderHash = h } -> + unless (h == txHash tx) $ + deleteTx memonly rbfcheck h Nothing -> do $(logErrorS) "BlockStore" $ "Missing unspent output for tx: " @@ -396,28 +399,24 @@ deleteUnconfirmedTx :: MonadImport m => Bool -> TxHash -> m () deleteUnconfirmedTx rbfcheck th = getActiveTxData th >>= \case - Just _ -> - deleteTx True rbfcheck th - Nothing -> - $(logDebugS) "BlockStore" $ - "Not found or already deleted: " <> txHashToHex th + Just _ -> deleteTx True rbfcheck th + Nothing -> $(logDebugS) "BlockStore" $ + "Not found or already deleted: " <> txHashToHex th -deleteTx - :: MonadImport m - => Bool -- ^ only delete transaction if unconfirmed - -> Bool -- ^ only delete RBF - -> TxHash - -> m () +deleteTx :: MonadImport m + => Bool -- ^ only delete transaction if unconfirmed + -> Bool -- ^ only delete RBF + -> TxHash + -> m () deleteTx memonly rbfcheck th = getChain memonly rbfcheck th >>= mapM_ (deleteSingleTx . txHash) -getChain - :: MonadImport m - => Bool -- ^ only delete transaction if unconfirmed - -> Bool -- ^ only delete RBF - -> TxHash - -> m [Tx] +getChain :: MonadImport m + => Bool -- ^ only delete transaction if unconfirmed + -> Bool -- ^ only delete RBF + -> TxHash + -> m [Tx] getChain memonly rbfcheck th = fmap sort_clean $ getActiveTxData th >>= \case @@ -426,23 +425,22 @@ "Transaction not found: " <> txHashToHex th throwError TxNotFound Just td - | memonly && confirmed (txDataBlock td) -> do - $(logErrorS) "BlockStore" $ - "Transaction already confirmed: " - <> txHashToHex th - throwError TxConfirmed - | rbfcheck -> - isRBF (txDataBlock td) (txData td) >>= \case - True -> go td - False -> do - $(logErrorS) "BlockStore" $ - "Double-spending transaction: " - <> txHashToHex th - throwError DoubleSpend - | otherwise -> go td + | memonly && confirmed (txDataBlock td) -> do + $(logErrorS) "BlockStore" $ + "Transaction already confirmed: " + <> txHashToHex th + throwError TxConfirmed + | rbfcheck -> + isRBF (txDataBlock td) (txData td) >>= \case + True -> go td + False -> do + $(logErrorS) "BlockStore" $ + "Double-spending transaction: " + <> txHashToHex th + throwError DoubleSpend + | otherwise -> go td where - sort_clean = - reverse . map snd . sortTxs . nub' + sort_clean = reverse . map snd . sortTxs . nub' go td = do let tx = txData td ss <- nub' . map spenderHash . I.elems <$> getSpenders th @@ -460,8 +458,7 @@ $(logDebugS) "BlockStore" $ "Deleting tx: " <> txHashToHex th getSpenders th >>= \case - m | I.null m -> - commitDelTx td + m | I.null m -> commitDelTx td | otherwise -> do $(logErrorS) "BlockStore" $ "Tried to delete spent tx: " @@ -469,31 +466,36 @@ throwError TxSpent commitDelTx :: MonadImport m => TxData -> m () -commitDelTx = commitModTx False [] +commitDelTx = commitModTx False -commitAddTx :: MonadImport m => [Unspent] -> TxData -> m () +commitAddTx :: MonadImport m => TxData -> m () commitAddTx = commitModTx True -commitModTx :: MonadImport m => Bool -> [Unspent] -> TxData -> m () -commitModTx add us td = do +commitModTx :: MonadImport m => Bool -> TxData -> m () +commitModTx add tx_data = do mapM_ mod_addr_tx (txDataAddresses td) mod_outputs mod_unspent - insertTx td' - updateMempool td' + insertTx td + updateMempool td where - td' = td { txDataDeleted = not add } - tx_ref = TxRef (txDataBlock td) (txHash (txData td)) - mod_addr_tx a | add = do - insertAddrTx a tx_ref - modAddressCount add a - | otherwise = do - deleteAddrTx a tx_ref - modAddressCount add a - mod_unspent | add = spendOutputs us td - | otherwise = unspendOutputs td - mod_outputs | add = addOutputs td - | otherwise = delOutputs td + tx = txData td + br = txDataBlock td + td = tx_data { txDataDeleted = not add } + tx_ref = TxRef br (txHash tx) + mod_addr_tx a + | add = do + insertAddrTx a tx_ref + modAddressCount add a + | otherwise = do + deleteAddrTx a tx_ref + modAddressCount add a + mod_unspent + | add = spendOutputs tx + | otherwise = unspendOutputs tx + mod_outputs + | add = addOutputs br tx + | otherwise = delOutputs br tx updateMempool :: MonadImport m => TxData -> m () updateMempool td@TxData{txDataDeleted = True} = @@ -503,44 +505,37 @@ updateMempool td@TxData{txDataBlock = BlockRef{}} = deleteFromMempool (txHash (txData td)) -spendOutputs :: MonadImport m => [Unspent] -> TxData -> m () -spendOutputs us td = - zipWithM_ (spendOutput (txHash (txData td))) [0 ..] us +spendOutputs :: MonadImport m => Tx -> m () +spendOutputs tx = + zipWithM_ (spendOutput (txHash tx)) [0 ..] (prevOuts tx) -addOutputs :: MonadImport m => TxData -> m () -addOutputs td = - zipWithM_ - (addOutput (txDataBlock td) . OutPoint (txHash (txData td))) - [0 ..] - (txOut (txData td)) +addOutputs :: MonadImport m => BlockRef -> Tx -> m () +addOutputs br tx = + zipWithM_ (addOutput br . OutPoint (txHash tx)) [0 ..] (txOut tx) isRBF :: StoreReadBase m => BlockRef -> Tx -> m Bool isRBF br tx - | confirmed br = - return False - | otherwise = - getNetwork >>= \net -> - if getReplaceByFee net - then go - else return False + | confirmed br = return False + | otherwise = + getNetwork >>= \net -> + if getReplaceByFee net + then go + else return False where - go | any ((< 0xffffffff - 1) . txInSequence) (txIn tx) = - return True - | otherwise = - carry_on + go | any ((< 0xffffffff - 1) . txInSequence) (txIn tx) = return True + | otherwise = carry_on carry_on = let hs = nub' $ map (outPointHash . prevOutput) (txIn tx) ck [] = return False ck (h : hs') = getActiveTxData h >>= \case Nothing -> return False - Just t - | confirmed (txDataBlock t) -> ck hs' - | txDataRBF t -> return True - | otherwise -> ck hs' + Just t | confirmed (txDataBlock t) -> ck hs' + | txDataRBF t -> return True + | otherwise -> ck hs' in ck hs addOutput :: MonadImport m => BlockRef -> OutPoint -> TxOut -> m () @@ -571,13 +566,11 @@ mod_addr_unspent | add = insertAddrUnspent | otherwise = deleteAddrUnspent -delOutputs :: MonadImport m => TxData -> m () -delOutputs td = - forM_ (zip [0..] outs) $ \(i, o) -> do - let op = OutPoint (txHash (txData td)) i - delOutput (txDataBlock td) op o - where - outs = txOut (txData td) +delOutputs :: MonadImport m => BlockRef -> Tx -> m () +delOutputs br tx = + forM_ (zip [0..] (txOut tx)) $ \(i, o) -> do + let op = OutPoint (txHash tx) i + delOutput br op o getImportTxData :: MonadImport m => TxHash -> m TxData getImportTxData th = @@ -592,34 +585,33 @@ guard (fromIntegral i < length (txOut tx)) return $ txOut tx !! fromIntegral i -spendOutput :: MonadImport m => TxHash -> Word32 -> Unspent -> m () -spendOutput th ix u = do - insertSpender (unspentPoint u) (Spender th ix) +spendOutput :: MonadImport m => TxHash -> Word32 -> OutPoint -> m () +spendOutput th ix op = do + u <- getUnspent op >>= \case + Just u -> return u + Nothing -> error $ "Could not find UTXO to spend: " <> show op + deleteUnspent op + insertSpender op (Spender th ix) let pk = B.Short.fromShort (unspentScript u) - case scriptToAddressBS pk of - Left _ -> return () - Right a -> do - decreaseBalance - (confirmed (unspentBlock u)) - a - (unspentAmount u) - deleteAddrUnspent a u - deleteUnspent (unspentPoint u) + forM_ (scriptToAddressBS pk) $ \a -> do + decreaseBalance + (confirmed (unspentBlock u)) + a + (unspentAmount u) + deleteAddrUnspent a u -unspendOutputs :: MonadImport m => TxData -> m () -unspendOutputs td = mapM_ unspendOutput (prevOuts (txData td)) +unspendOutputs :: MonadImport m => Tx -> m () +unspendOutputs = mapM_ unspendOutput . prevOuts unspendOutput :: MonadImport m => OutPoint -> m () unspendOutput op = do t <- getActiveTxData (outPointHash op) >>= \case - Nothing -> - error $ "Could not find tx data: " <> show (outPointHash op) + Nothing -> error $ "Could not find tx data: " <> show (outPointHash op) Just t -> return t - o <- case getTxOut (outPointIndex op) (txData t) of - Nothing -> - error $ "Could not find output: " <> show op - Just o -> return o - let m = eitherToMaybe (scriptToAddressBS (scriptOutput o)) + let o = fromMaybe + (error ("Could not find output: " <> show op)) + (getTxOut (outPointIndex op) (txData t)) + m = eitherToMaybe (scriptToAddressBS (scriptOutput o)) u = Unspent { unspentAmount = outValue o , unspentBlock = txDataBlock t , unspentScript = B.Short.toShort (scriptOutput o) @@ -643,13 +635,12 @@ increaseBalance :: MonadImport m => Bool -> Address -> Word64 -> m () increaseBalance conf = modBalance conf True -modBalance - :: MonadImport m - => Bool -- ^ confirmed - -> Bool -- ^ add - -> Address - -> Word64 - -> m () +modBalance :: MonadImport m + => Bool -- ^ confirmed + -> Bool -- ^ add + -> Address + -> Word64 + -> m () modBalance conf add a val = do b <- getDefaultBalance a setBalance $ (g . f) b diff --git a/src/Haskoin/Store/Manager.hs b/src/Haskoin/Store/Manager.hs --- a/src/Haskoin/Store/Manager.hs +++ b/src/Haskoin/Store/Manager.hs @@ -87,6 +87,8 @@ -- ^ cache xpubs with more than this many used addresses , storeConfMaxKeys :: !Integer -- ^ maximum number of keys in Redis cache + , storeConfNoMempool :: !Bool + -- ^ do not index new mempool transactions , storeConfWipeMempool :: !Bool -- ^ wipe mempool when starting , storeConfPeerTimeout :: !NominalDiffTime @@ -137,6 +139,7 @@ , blockConfListener = pub , blockConfDB = db , blockConfNet = storeConfNetwork cfg + , blockConfNoMempool = storeConfNoMempool cfg , blockConfWipeMempool = storeConfWipeMempool cfg , blockConfPeerTimeout = storeConfPeerTimeout cfg } diff --git a/src/Haskoin/Store/Web.hs b/src/Haskoin/Store/Web.hs --- a/src/Haskoin/Store/Web.hs +++ b/src/Haskoin/Store/Web.hs @@ -72,7 +72,7 @@ responseStatus) import Network.Wai.Handler.Warp (defaultSettings, setHost, setPort) -import NQE (Inbox, Publisher, receive, +import NQE (Inbox, receive, withSubscription) import Text.Printf (printf) import UnliftIO (MonadIO, MonadUnliftIO, @@ -113,6 +113,7 @@ , webReqLog :: !Bool , webTimeouts :: !WebTimeouts , webVersion :: !String + , webNoMempool :: !Bool } data WebTimeouts = WebTimeouts @@ -664,11 +665,8 @@ -- POST Transaction -- scottyPostTx :: (MonadUnliftIO m, MonadLoggerIO m) => PostTx -> WebT m TxId -scottyPostTx (PostTx tx) = do - net <- lift $ asks (storeNetwork . webStore) - pub <- lift $ asks (storePublisher . webStore) - mgr <- lift $ asks (storeManager . webStore) - lift (publishTx net pub mgr tx) >>= \case +scottyPostTx (PostTx tx) = + lift ask >>= \cfg -> lift (publishTx cfg tx) >>= \case Right () -> return $ TxId (txHash tx) Left e@(PubReject _) -> S.raise $ UserError $ show e _ -> S.raise ServerError @@ -676,17 +674,18 @@ -- | Publish a new transaction to the network. publishTx :: (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) - => Network - -> Publisher StoreEvent - -> PeerManager + => WebConfig -> Tx -> m (Either PubExcept ()) -publishTx net pub mgr tx = +publishTx cfg tx = withSubscription pub $ \s -> getTransaction (txHash tx) >>= \case Just _ -> return $ Right () Nothing -> go s where + pub = storePublisher (webStore cfg) + mgr = storeManager (webStore cfg) + net = storeNetwork (webStore cfg) go s = getPeers mgr >>= \case [] -> return $ Left PubNoPeers @@ -701,7 +700,9 @@ p f p s t = 5 * 1000 * 1000 - f p s = + f p s + | webNoMempool cfg = return $ Right () + | otherwise = liftIO (timeout t (g p s)) >>= \case Nothing -> return $ Left PubTimeout Just (Left e) -> return $ Left e @@ -724,7 +725,7 @@ wl <- lift $ asks webMaxLimits let wl' = wl { maxLimitCount = 0 } l = Limits (validateLimit wl' False limitM) (fromIntegral o) Nothing - map txRefHash . applyLimits l <$> getMempool + map snd . applyLimits l <$> getMempool scottyEvents :: MonadLoggerIO m => WebT m () scottyEvents = do @@ -899,17 +900,20 @@ return TimeHealth {..} lastTxHealthCheck :: (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) - => Chain -> WebTimeouts -> m TimeHealth -lastTxHealthCheck ch tos = do + => WebConfig -> m TimeHealth +lastTxHealthCheck WebConfig {..} = do n <- fromIntegral . systemSeconds <$> liftIO getSystemTime b <- fromIntegral . H.blockTimestamp . H.nodeHeader <$> chainGetBest ch t <- listToMaybe <$> getMempool >>= \case - Just t -> let x = fromIntegral $ memRefTime $ txRefBlock t + Just t -> let x = fromIntegral $ fst t in return $ max x b Nothing -> return b let timeHealthAge = n - t - timeHealthMax = fromIntegral $ txTimeout tos + timeHealthMax = fromIntegral to return TimeHealth {..} + where + ch = storeChain webStore + to = if webNoMempool then blockTimeout webTimeouts else txTimeout webTimeouts pendingTxsHealthCheck :: (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) => WebConfig -> m MaxHealth @@ -930,7 +934,7 @@ healthCheck cfg@WebConfig {..} = do healthBlocks <- blockHealthCheck cfg healthLastBlock <- lastBlockHealthCheck (storeChain webStore) webTimeouts - healthLastTx <- lastTxHealthCheck (storeChain webStore) webTimeouts + healthLastTx <- lastTxHealthCheck cfg healthPendingTxs <- pendingTxsHealthCheck cfg healthPeers <- peerHealthCheck (storeManager webStore) let healthNetwork = getNetworkName (storeNetwork webStore) diff --git a/test/Haskoin/StoreSpec.hs b/test/Haskoin/StoreSpec.hs --- a/test/Haskoin/StoreSpec.hs +++ b/test/Haskoin/StoreSpec.hs @@ -87,6 +87,7 @@ , storeConfInitialGap = 20 , storeConfCacheMin = 100 , storeConfMaxKeys = 100 * 1000 * 1000 + , storeConfNoMempool = False , storeConfWipeMempool = False , storeConfPeerTimeout = 60 , storeConfPeerMaxLife = 48 * 3600