diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -115,6 +115,7 @@ syncMempool :: !Bool, peerTimeout :: !Int, maxPeerLife :: !Int, + mempoolTimeout :: !Int, maxPeers :: !Int, statsd :: !Bool, statsdHost :: !String, @@ -176,6 +177,8 @@ env "WIPE_MEMPOOL" False parseBool syncMempool <- env "SYNC_MEMPOOL" False parseBool + mempoolTimeout <- + env "MEMPOOL_TIMEOUT" 14 readMaybe peerTimeout <- env "PEER_TIMEOUT" 120 readMaybe maxPeerLife <- @@ -427,6 +430,13 @@ flag c.syncMempool True $ long "sync-mempool" <> help "Attempt to download peer mempools" + mempoolTimeout <- + option auto $ + metavar "DAYS" + <> long "mempool-timeout" + <> help "Cull old mempool transactions" + <> showDefault + <> value c.mempoolTimeout peerTimeout <- option auto $ metavar "SECONDS" @@ -574,6 +584,7 @@ wipeMempool = cfg.wipeMempool, noMempool = cfg.noMempool, syncMempool = cfg.syncMempool, + mempoolTimeout = cfg.mempoolTimeout, peerTimeout = fromIntegral cfg.peerTimeout, maxPeerLife = fromIntegral cfg.maxPeerLife, connect = withConnection, diff --git a/haskoin-store.cabal b/haskoin-store.cabal --- a/haskoin-store.cabal +++ b/haskoin-store.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: haskoin-store -version: 1.5.13 +version: 1.5.14 synopsis: Storage and index for Bitcoin and Bitcoin Cash description: Please see the README on GitHub at category: Bitcoin, Finance, Network @@ -66,7 +66,7 @@ , random >=1.1 , rocksdb-haskell-jprupp >=2.1.3 , rocksdb-query >=0.4.0 - , scotty >=0.20 + , scotty >=0.22 , statsd-rupp >=0.4 , stm >=2.5.0.0 , string-conversions >=0.4.0.1 @@ -121,7 +121,7 @@ , random >=1.1 , rocksdb-haskell-jprupp >=2.1.3 , rocksdb-query >=0.4.0 - , scotty >=0.20 + , scotty >=0.22 , statsd-rupp >=0.4 , stm >=2.5.0.0 , string-conversions >=0.4.0.1 @@ -180,7 +180,7 @@ , random >=1.1 , rocksdb-haskell-jprupp >=2.1.3 , rocksdb-query >=0.4.0 - , scotty >=0.20 + , scotty >=0.22 , statsd-rupp >=0.4 , stm >=2.5.0.0 , string-conversions >=0.4.0.1 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 @@ -323,6 +323,8 @@ -- | sync mempool from peers syncMempool :: !Bool, -- | disconnect syncing peer if inactive for this long + mempoolTimeout :: !Int, + -- | delete transactions older than this number of days from mempool peerTimeout :: !NominalDiffTime, stats :: !(Maybe Stats) } @@ -823,10 +825,30 @@ Left e -> report_error e Right _ -> return () report_error e = do - $(logErrorS) "BlockImport" $ + $(logErrorS) "BlockStore" $ "Error processing mempool: " <> cs (show e) throwIO e +pruneMempool :: (MonadLoggerIO m) => BlockT m () +pruneMempool = + guardMempool . notify Nothing $ do + days <- asks (.config.mempoolTimeout) + when (days > 0) $ do + mempool <- reverse <$> getMempool + time <- (floor . utcTimeToPOSIXSeconds) <$> liftIO getCurrentTime + let thresh = time - (fromIntegral days * 24 * 60 * 60) + txs = take 1000 $ map snd $ takeWhile ((< thresh) . fst) mempool + net <- getNetwork + ctx <- getCtx + when (length txs > 0) $ do + $(logInfoS) "BlockStore" $ + "Deleting " <> cs (show (length txs)) <> " old transactions from mempool" + runImport net ctx (mapM_ (deleteUnconfirmedTx False) txs) >>= \case + Left e -> + $(logErrorS) "BlockStore" $ + "Error pruning mempool: " <> cs (show e) + Right () -> return () + processTxs :: (MonadLoggerIO m) => Peer -> @@ -1184,6 +1206,7 @@ trySyncing processMempool pruneOrphans + pruneMempool checkTime atomically (r ()) @@ -1191,12 +1214,7 @@ pingMe mbox = forever $ do BlockPing `query` mbox - delay <- - liftIO $ - randomRIO - ( 100 * 1000, - 1000 * 1000 - ) + delay <- liftIO $ randomRIO (100 * 1000, 1000 * 1000) threadDelay delay blockStorePeerConnect :: (MonadIO m) => Peer -> BlockStore -> m () 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 @@ -146,6 +146,8 @@ -- | sync mempool from peers syncMempool :: !Bool, -- | disconnect peer if message not received for this many seconds + mempoolTimeout :: !Int, + -- | delete mempool transactions older than this number of days peerTimeout :: !NominalDiffTime, -- | disconnect peer if it has been connected this long maxPeerLife :: !NominalDiffTime, @@ -222,6 +224,7 @@ noMempool = cfg.noMempool, wipeMempool = cfg.wipeMempool, syncMempool = cfg.syncMempool, + mempoolTimeout = cfg.mempoolTimeout, peerTimeout = cfg.peerTimeout, stats = cfg.stats } 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 @@ -649,11 +649,6 @@ toEncoding toJSON pathCompact - (GetMempool <$> paramOptional <*> parseOffset) - (fmap SerialList . scottyMempool) - toEncoding - toJSON - pathCompact (GetAddrTxs <$> paramCapture <*> parseLimits) (fmap SerialList . scottyAddrTxs) toEncoding @@ -679,8 +674,13 @@ toEncoding toJSON S.get "/events" scottyEvents - S.get "/dbstats" scottyDbStats unless cfg.noSlow $ do + S.get "/dbstats" scottyDbStats + pathCompact + (GetMempool <$> paramOptional <*> parseOffset) + (fmap SerialList . scottyMempool) + toEncoding + toJSON pathCompact (GetBlocks <$> paramRequired <*> paramDef) (fmap SerialList . scottyBlocks) diff --git a/test/Haskoin/StoreSpec.hs b/test/Haskoin/StoreSpec.hs --- a/test/Haskoin/StoreSpec.hs +++ b/test/Haskoin/StoreSpec.hs @@ -104,6 +104,7 @@ noMempool = False, wipeMempool = False, syncMempool = False, + mempoolTimeout = 14, peerTimeout = 60, maxPeerLife = 48 * 3600, connect = dummyPeerConnect net ad,