haskoin-store 0.37.1 → 0.37.2
raw patch · 12 files changed
+346/−396 lines, 12 filesdep ~haskoin-storedep ~haskoin-store-data
Dependency ranges changed: haskoin-store, haskoin-store-data
Files
- app/Main.hs +15/−0
- haskoin-store.cabal +6/−6
- src/Haskoin/Store/BlockStore.hs +28/−22
- src/Haskoin/Store/Cache.hs +6/−11
- src/Haskoin/Store/Common.hs +4/−11
- src/Haskoin/Store/Database/Reader.hs +4/−15
- src/Haskoin/Store/Database/Types.hs +1/−0
- src/Haskoin/Store/Database/Writer.hs +130/−178
- src/Haskoin/Store/Logic.hs +127/−136
- src/Haskoin/Store/Manager.hs +3/−0
- src/Haskoin/Store/Web.hs +21/−17
- test/Haskoin/StoreSpec.hs +1/−0
app/Main.hs view
@@ -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
haskoin-store.cabal view
@@ -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 <https://github.com/haskoin/haskoin-store#readme> 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
src/Haskoin/Store/BlockStore.hs view
@@ -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
src/Haskoin/Store/Cache.hs view
@@ -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
src/Haskoin/Store/Common.hs view
@@ -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
src/Haskoin/Store/Database/Reader.hs view
@@ -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
src/Haskoin/Store/Database/Types.hs view
@@ -239,6 +239,7 @@ guard . (== 0x01) =<< getWord8 BlockKey <$> get +instance Key BlockKey instance KeyValue BlockKey BlockData -- | Block height database key.
src/Haskoin/Store/Database/Writer.hs view
@@ -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) }
src/Haskoin/Store/Logic.hs view
@@ -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
src/Haskoin/Store/Manager.hs view
@@ -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 }
src/Haskoin/Store/Web.hs view
@@ -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)
test/Haskoin/StoreSpec.hs view
@@ -87,6 +87,7 @@ , storeConfInitialGap = 20 , storeConfCacheMin = 100 , storeConfMaxKeys = 100 * 1000 * 1000+ , storeConfNoMempool = False , storeConfWipeMempool = False , storeConfPeerTimeout = 60 , storeConfPeerMaxLife = 48 * 3600