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.14.1 +### Fixed +- Correct flawed peer locking logic in Chain actor. + ## 0.14.0 ### Changed - Massively refactor everything in a non-backwards-compatible way. diff --git a/haskoin-node.cabal b/haskoin-node.cabal --- a/haskoin-node.cabal +++ b/haskoin-node.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 92f53efa89a440e6a96b4108646c17c6fc9315a7bf8ba2ecadbac8fb2d295f73 +-- hash: b18b0ea7428050a6d41c0bbd2a235b1c06b2ae8792339a9a1e7475ab94db23fc name: haskoin-node -version: 0.14.0 +version: 0.14.1 synopsis: P2P library for Bitcoin and Bitcoin Cash description: Please see the README on GitHub at category: Bitcoin, Finance, Network diff --git a/src/Haskoin/Node/Chain.hs b/src/Haskoin/Node/Chain.hs --- a/src/Haskoin/Node/Chain.hs +++ b/src/Haskoin/Node/Chain.hs @@ -25,7 +25,7 @@ , chainHeaders ) where -import Control.Monad (forM_, forever, guard, void, when) +import Control.Monad (forM_, forever, guard, when) import Control.Monad.Except (runExceptT, throwError) import Control.Monad.Logger (MonadLoggerIO, logDebugS, logErrorS, logInfoS) @@ -245,20 +245,20 @@ publish e pub processHeaders :: MonadChain m => Peer -> [BlockHeader] -> m () -processHeaders p hs = void . runMaybeT $ do +processHeaders p hs = do $(logDebugS) "Chain" $ "Processing " <> cs (show (length hs)) <> " headers from peer: " <> peerText p net <- asks (chainConfNetwork . myConfig) now <- liftIO getCurrentTime - pbest <- lift $ withBlockHeaders getBestBlockHeader - lift (importHeaders net now hs) >>= \case + pbest <- withBlockHeaders getBestBlockHeader + importHeaders net now hs >>= \case Left e -> do $(logErrorS) "Chain" $ "Could not connect headers from peer: " <> peerText p e `killPeer` p - Right done -> lift $ do + Right done -> do setLastReceived best <- withBlockHeaders getBestBlockHeader when (nodeHeader pbest /= nodeHeader best) $ @@ -272,13 +272,10 @@ else syncPeer p syncNewPeer :: MonadChain m => m () -syncNewPeer = - getSyncingPeer >>= \s -> - when (isNothing s) $ - nextPeer >>= \case - Nothing -> - $(logDebugS) "Chain" - "No more peers to sync against" +syncNewPeer = getSyncingPeer >>= \case + Just _ -> return () + Nothing -> nextPeer >>= \case + Nothing -> return () Just p -> do $(logDebugS) "Chain" $ "Syncing against peer: " <> peerText p @@ -286,9 +283,10 @@ syncNotif :: MonadChain m => m () syncNotif = - notifySynced >>= \x -> - when x $ withBlockHeaders getBestBlockHeader >>= - chainEvent . ChainSynced + notifySynced >>= \case + False -> return () + True -> withBlockHeaders getBestBlockHeader >>= + chainEvent . ChainSynced syncPeer :: MonadChain m => Peer -> m () syncPeer p = do @@ -302,11 +300,12 @@ Nothing -> syncing_new t forM_ m $ \g -> do $(logDebugS) "Chain" $ - "Requesting headers from peer: " <> peerText p + "Requesting headers from peer: " + <> peerText p MGetHeaders g `sendMessage` p where syncing_new t = - setBusy p >>= \case + setSyncingPeer p >>= \case False -> return Nothing True -> do $(logDebugS) "Chain" $ @@ -343,7 +342,8 @@ $(logErrorS) "Chain" $ "Syncing peer timed out: " <> peerText p PeerTimeout `killPeer` p - _ -> return () + | otherwise -> return () + Nothing -> syncNewPeer withSyncLoop :: (MonadUnliftIO m, MonadLoggerIO m) => Chain -> m a -> m a @@ -454,14 +454,15 @@ -- | Get next peer to sync against from the queue. nextPeer :: MonadChain m => m (Maybe Peer) -nextPeer = - go =<< newPeers <$> (readTVarIO =<< asks chainState) +nextPeer = do + ps <- newPeers <$> (readTVarIO =<< asks chainState) + go ps where go [] = return Nothing go (p:ps) = - getBusy p >>= \case - True -> go ps - False -> return (Just p) + setSyncingPeer p >>= \case + True -> return (Just p) + False -> go ps -- | Set a syncing peer and generate a 'GetHeaders' data structure with a block -- locator to send to that peer for syncing. @@ -514,24 +515,59 @@ getSyncingPeer = fmap chainSyncPeer . chainSyncing <$> (readTVarIO =<< asks chainState) +setSyncingPeer :: MonadChain m => Peer -> m Bool +setSyncingPeer p = + setBusy p >>= \case + False -> do + $(logDebugS) "Chain" $ + "Could not lock peer: " <> peerText p + return False + True -> do + $(logDebugS) "Chain" $ + "Locked peer: " <> peerText p + set_it + return True + where + set_it = do + now <- liftIO getCurrentTime + box <- asks chainState + atomically $ modifyTVar box $ \s -> + s { chainSyncing = + Just ChainSync { chainSyncPeer = p + , chainTimestamp = now + , chainHighest = Nothing + } + } + + -- | Remove a peer from the queue of peers to sync and unset the syncing peer if --- it is set to the provided value. +-- it is set to the provided peer. finishPeer :: MonadChain m => Peer -> m () finishPeer p = - asks chainState >>= - remove_peer >>= \x -> when x $ do - $(logDebugS) "Chain" $ "Free peer: " <> peerText p - setFree p + asks chainState >>= remove_peer >>= \case + False -> + $(logDebugS) "Chain" $ + "Removed peer from queue: " <> peerText p + True -> do + $(logDebugS) "Chain" $ + "Releasing syncing peer: " <> peerText p + setFree p where - remove_peer st = - atomically $ readTVar st >>= \s -> do - let is_me = maybe False ((== p) . chainSyncPeer) (chainSyncing s) - new_sync = if is_me then Nothing else chainSyncing s - new_peers = delete p (newPeers s) - writeTVar st $ - s { newPeers = new_peers - , chainSyncing = new_sync } - return is_me + remove_peer st = atomically $ + readTVar st >>= \s -> case chainSyncing s of + Just ChainSync { chainSyncPeer = p' } + | p == p' -> do + unset_syncing st + return True + _ -> do + remove_from_queue st + return False + unset_syncing st = + modifyTVar st $ \x -> + x { chainSyncing = Nothing } + remove_from_queue st = + modifyTVar st $ \x -> + x { newPeers = delete p (newPeers x) } -- | Return syncing peer data. chainSyncingPeer :: MonadChain m => m (Maybe ChainSync)