diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,6 +4,10 @@ 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). +## 0.9.1 +### Changed +- Keep track of last synced header from a peer to avoid endless loops on large reorgs. + ## 0.9.0 ### Changed - Use an STM listener instead of a publisher for the node API. diff --git a/haskoin-node.cabal b/haskoin-node.cabal --- a/haskoin-node.cabal +++ b/haskoin-node.cabal @@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 1a84bd58732e99811ec849f42d0294accf3b078c9f8663c2b1e7f67614f0e359 +-- hash: e0be9f76327041faf731ead5e41e6c3982f3d0b325a0b1b8d19ac514c78dc00e name: haskoin-node -version: 0.9.0 +version: 0.9.1 synopsis: Haskoin Node P2P library for Bitcoin and Bitcoin Cash description: Bitcoin and Bitcoin Cash peer-to-peer protocol library featuring headers-first synchronisation. category: Bitcoin, Finance, Network diff --git a/src/Network/Haskoin/Node/Chain.hs b/src/Network/Haskoin/Node/Chain.hs --- a/src/Network/Haskoin/Node/Chain.hs +++ b/src/Network/Haskoin/Node/Chain.hs @@ -53,7 +53,7 @@ st <- newTVarIO ChainState - { syncingPeer = Nothing + { chainSyncing = Nothing , mySynced = False , newPeers = [] } @@ -135,7 +135,10 @@ syncPeer :: MonadChain m => Peer -> SockAddr -> m () syncPeer p a = do $(logInfoS) "Chain" $ "Syncing against peer " <> peerString (Just a) - bb <- getBestBlockHeader + bb <- chainSyncingPeer >>= \case + Just ChainSync {chainSyncPeer = (p', _), chainHighest = Just g} + | p == p' -> return g + _ -> getBestBlockHeader now <- round <$> liftIO getPOSIXTime gh <- syncHeaders now bb (p, a) MGetHeaders gh `sendMessage` p @@ -169,9 +172,9 @@ chainMessage ChainPing = do ChainConfig {chainConfTimeout = to} <- asks myReader now <- round <$> liftIO getPOSIXTime - lastMessage >>= \case + chainSyncingPeer >>= \case Nothing -> return () - Just ((p, a), t) + Just ChainSync {chainSyncPeer = (p, a), chainTimestamp = t} | now - t > fromIntegral to -> do let s = peerString (Just a) $(logErrorS) "Chain" $ "Syncing peer timed out: " <> s @@ -190,7 +193,7 @@ peerAddr :: MonadChain m => Peer -> m (Maybe SockAddr) peerAddr p = asks chainState >>= readTVarIO >>= \s -> - let ps = newPeers s <> maybeToList (fst <$> syncingPeer s) + let ps = newPeers s <> maybeToList (chainSyncPeer <$> chainSyncing s) in return $ snd <$> find ((== p) . fst) ps peerString :: Maybe SockAddr -> Text diff --git a/src/Network/Haskoin/Node/Chain/Logic.hs b/src/Network/Haskoin/Node/Chain/Logic.hs --- a/src/Network/Haskoin/Node/Chain/Logic.hs +++ b/src/Network/Haskoin/Node/Chain/Logic.hs @@ -19,7 +19,6 @@ -} module Network.Haskoin.Node.Chain.Logic where -import Control.Arrow import Control.Monad import Control.Monad.Except import Control.Monad.Reader @@ -55,9 +54,15 @@ return ChainDataVersionKey put ChainDataVersionKey = S.putWord8 0x92 +data ChainSync p = ChainSync + { chainSyncPeer :: !p + , chainTimestamp :: !Timestamp + , chainHighest :: !(Maybe BlockNode) + } + -- | Mutable state for the header chain process. data ChainState p = ChainState - { syncingPeer :: !(Maybe (p, Timestamp)) + { chainSyncing :: !(Maybe (ChainSync p)) -- ^ peer to sync against and time of last received message , newPeers :: ![p] -- ^ queue of peers to sync against @@ -160,7 +165,7 @@ -- headers is 2000, which means that there are possibly more headers to sync -- from whatever peer delivered these. importHeaders :: - (MonadIO m, BlockHeaders m) + (MonadIO m, BlockHeaders m, MonadChainLogic a p m) => Network -> Timestamp -> [BlockHeader] @@ -168,7 +173,18 @@ importHeaders net now hs = runExceptT $ lift (connectBlocks net now hs) >>= \case - Right _ -> + Right _ -> do + case hs of + [] -> return () + _ -> do + bb <- getBlockHeader (headerHash (last hs)) + box <- asks chainState + atomically . modifyTVar box $ \s -> + s + { chainSyncing = + (\x -> x {chainHighest = bb}) <$> + chainSyncing s + } case length hs of 2000 -> return False _ -> return True @@ -190,7 +206,7 @@ st <- asks chainState MaybeT . atomically . runMaybeT $ do s <- lift $ readTVar st - guard . isNothing $ syncingPeer s + guard . isNothing $ chainSyncing s guard . null $ newPeers s guard . not $ mySynced s lift $ writeTVar st s {mySynced = True} @@ -211,7 +227,16 @@ syncHeaders now bb p = do st <- asks chainState atomically . modifyTVar st $ \s -> - s {syncingPeer = Just (p, now), newPeers = delete p (newPeers s)} + s + { chainSyncing = + Just + ChainSync + { chainSyncPeer = p + , chainTimestamp = now + , chainHighest = Nothing + } + , newPeers = delete p (newPeers s) + } loc <- blockLocator bb return GetHeaders @@ -226,7 +251,7 @@ setLastReceived now = do st <- asks chainState atomically . modifyTVar st $ \s -> - s {syncingPeer = second (const now) <$> syncingPeer s} + s {chainSyncing = (\p -> p {chainTimestamp = now}) <$> chainSyncing s} -- | Add a new peer to the queue of peers to sync against. addPeer :: (Eq p, MonadIO m, MonadChainLogic a p m) => p -> m () @@ -236,13 +261,22 @@ -- | Get syncing peer if there is one. getSyncingPeer :: (MonadChainLogic a p m, MonadIO m) => m (Maybe p) -getSyncingPeer = fmap fst . syncingPeer <$> (readTVarIO =<< asks chainState) +getSyncingPeer = fmap chainSyncPeer . chainSyncing <$> (readTVarIO =<< asks chainState) -- | Set syncing peer to the pone provided. setSyncingPeer :: (MonadChainLogic a p m, MonadIO m) => Timestamp -> p -> m () setSyncingPeer now p = asks chainState >>= \v -> - atomically . modifyTVar v $ \s -> s {syncingPeer = Just (p, now)} + atomically . modifyTVar v $ \s -> + s + { chainSyncing = + Just + ChainSync + { chainSyncPeer = p + , chainTimestamp = now + , chainHighest = Nothing + } + } -- | Return 'True' if the chain has ever been considered synced. it will always -- return 'True', even if the chain gets out of sync for any reason. @@ -263,13 +297,16 @@ atomically . modifyTVar st $ \s -> s { newPeers = delete p (newPeers s) - , syncingPeer = - case syncingPeer s of - Just (p', _) + , chainSyncing = + case chainSyncing s of + Just ChainSync { chainSyncPeer = p' + , chainTimestamp = _ + , chainHighest = _ + } | p == p' -> Nothing - _ -> syncingPeer s + _ -> chainSyncing s } --- | Return the syncing peer and time of last communication received, if any. -lastMessage :: (MonadChainLogic a p m, MonadIO m) => m (Maybe (p, Timestamp)) -lastMessage = syncingPeer <$> (readTVarIO =<< asks chainState) +-- | Return syncing peer data. +chainSyncingPeer :: (MonadChainLogic a p m, MonadIO m) => m (Maybe (ChainSync p)) +chainSyncingPeer = chainSyncing <$> (readTVarIO =<< asks chainState)