haskoin-node 2.1.1 → 2.1.2
raw patch · 4 files changed
+54/−17 lines, 4 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- CHANGELOG.md +9/−0
- haskoin-node.cabal +1/−1
- src/Haskoin/Node/Chain.hs +3/−2
- test/Haskoin/NodeSpec.hs +41/−14
CHANGELOG.md view
@@ -4,6 +4,15 @@ The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0.html). +## [2.1.2] - 2026-11-04++### Fixed++- An empty headers message from the syncing peer ends the header sync. The+ node used to take it as a reason to ask the same peer again, and kept+ sending getheaders in a tight loop, thousands per second, whenever its+ best header was the peer's tip after a full batch of 2000.+ ## [2.1.1] - 2026-11-04 ### Changed
haskoin-node.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: haskoin-node-version: 2.1.1+version: 2.1.2 synopsis: P2P library for Bitcoin and Bitcoin Cash description: Please see the README on GitHub at <https://github.com/jprupp/haskoin-node#readme> category: Bitcoin, Finance, Network
src/Haskoin/Node/Chain.hs view
@@ -381,7 +381,8 @@ -- | Import a bunch of continuous headers. Returns 'True' if the number of -- headers is less than 2000, which means that there are no more headers to sync--- from the peer that delivered these.+-- from the peer that delivered these. An empty headers message, which a peer+-- sends when it has nothing after the locator, counts as done too. importHeaders :: (MonadIO m) => Chain -> UTCTime -> [BlockHeader] -> m (Maybe Bool) importHeaders ch now hs =@@ -390,7 +391,7 @@ logError ch.config.logger ("connectBlocks: " <> cs e) return Nothing Right bns- | null bns -> return (Just False)+ | null bns -> return (Just True) | otherwise -> do bb <- get_last atomically . modifyTVar ch.state $ \s ->
test/Haskoin/NodeSpec.hs view
@@ -32,19 +32,25 @@ import Test.Hspec import Test.Hspec.QuickCheck import UnliftIO+import UnliftIO.Concurrent (threadDelay) data TestNode = TestNode { testMgr :: PeerMgr, testChain :: Chain,- nodeEvents :: Inbox NodeEvent+ nodeEvents :: Inbox NodeEvent,+ -- | how many getheaders messages the mock peer has received+ getHeadersCount :: TVar Int } +-- | Connect to a mock peer that serves these blocks. dummyPeerConnect ::+ [Block] ->+ TVar Int -> Network -> NetworkAddress -> SockAddr -> WithConnection-dummyPeerConnect net ad sa f = do+dummyPeerConnect blocks count net ad sa f = do r <- newInbox s <- newInbox let s' = inboxToMailbox s@@ -63,10 +69,14 @@ runConduit $ forever (receive r >>= yield) .| inc- .| concatMapC mockPeerReact+ .| iterMC count_getheaders+ .| concatMapC (mockPeerReact blocks) .| outc .| awaitForever (`send` s) outc = mapMC $ \msg -> return $ runPut (putMessage net msg)+ count_getheaders = \case+ MGetHeaders _ -> atomically (modifyTVar' count (+ 1))+ _ -> return () inc = forever $ do x <- takeCE 24 .| foldC@@ -80,19 +90,19 @@ "Dummy peer could not decode payload: " <> show e Right msg -> yield msg -mockPeerReact :: Message -> [Message]-mockPeerReact (MPing (Ping n)) = [MPong (Pong n)]-mockPeerReact (MVersion _) = [MVerAck]-mockPeerReact (MGetHeaders (GetHeaders _ _hs _)) = [MHeaders (Headers hs')]+mockPeerReact :: [Block] -> Message -> [Message]+mockPeerReact _ (MPing (Ping n)) = [MPong (Pong n)]+mockPeerReact _ (MVersion _) = [MVerAck]+mockPeerReact blocks (MGetHeaders (GetHeaders _ _hs _)) = [MHeaders (Headers hs')] where f b = (b.header, (VarInt . fromIntegral . length) b.txs)- hs' = map f allBlocks-mockPeerReact (MGetData (GetData ivs)) = mapMaybe f ivs+ hs' = map f blocks+mockPeerReact blocks (MGetData (GetData ivs)) = mapMaybe f ivs where- f (InvVector InvBlock h) = MBlock <$> find (l h) allBlocks+ f (InvVector InvBlock h) = MBlock <$> find (l h) blocks f _ = Nothing l h b = headerHash b.header == BlockHash h-mockPeerReact _ = []+mockPeerReact _ _ = [] spec :: Spec spec = do@@ -140,6 +150,15 @@ testMerkle b1 testMerkle b2 describe "chain on test network" $ do+ it "stops asking a peer that has no more headers" $+ -- The peer answers getheaders with an empty headers message, as a+ -- peer does when the node already has its whole chain. The node must+ -- take that as the end of the sync instead of asking again.+ withTestNodeBlocks [] net "no-headers" $ \TestNode {..} -> do+ _ <- waitForPeer nodeEvents+ atomically $ readTVar getHeadersCount >>= checkSTM . (>= 1)+ threadDelay (1000 * 1000)+ readTVarIO getHeadersCount `shouldReturn` 1 it "syncs some headers" $ withTestNode net "connect-sync" $ \TestNode {..} -> do let bh =@@ -188,8 +207,15 @@ withTestNode :: (MonadUnliftIO m) => Network -> String -> (TestNode -> m a) -> m a-withTestNode net str f = flip runContT return $ do+withTestNode = withTestNodeBlocks allBlocks++-- | Like 'withTestNode', with the mock peer serving these blocks.+withTestNodeBlocks ::+ (MonadUnliftIO m) =>+ [Block] -> Network -> String -> (TestNode -> m a) -> m a+withTestNodeBlocks blocks net str f = flip runContT return $ do w <- ContT $ withSystemTempDirectory ("haskoin-node-test-" <> str <> "-")+ count <- newTVarIO 0 pub <- ContT withPublisher sub <- ContT $ withSubscription pub db <- ContT $ withLifted (R.withDBCF w cfg cols)@@ -214,7 +240,7 @@ pub = pub, timeout = 120, maxPeerLife = 48 * 3600,- connect = dummyPeerConnect net ad,+ connect = dummyPeerConnect blocks count net ad, logger = Logger {level = LevelError, source = "", push = \_ -> return ()} } Node mgr ch <- ContT $ withNode cfg'@@ -223,7 +249,8 @@ TestNode { testMgr = mgr, testChain = ch,- nodeEvents = sub+ nodeEvents = sub,+ getHeadersCount = count } where cfg = def {R.createIfMissing = True, R.errorIfExists = True}