haskoin-store 1.5.13 → 1.5.14

raw patch · 6 files changed

+50/−17 lines, 6 filesdep ~scottyPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: scotty

API changes (from Hackage documentation)

Files

• app/Main.hs +11/−0
• haskoin-store.cabal +4/−4
• src/Haskoin/Store/BlockStore.hs +25/−7
• src/Haskoin/Store/Manager.hs +3/−0
• src/Haskoin/Store/Web.hs +6/−6
• test/Haskoin/StoreSpec.hs +1/−0

@@ -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,

@@ -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 <https://github.com/haskoin/haskoin-store#readme> 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

@@ -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 ()

@@ -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     }

@@ -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)

@@ -104,6 +104,7 @@                 noMempool = False,                 wipeMempool = False,                 syncMempool = False,+                mempoolTimeout = 14,                 peerTimeout = 60,                 maxPeerLife = 48 * 3600,                 connect = dummyPeerConnect net ad,