haskoin-node 0.9.0 → 0.9.1
raw patch · 4 files changed
+67/−23 lines, 4 files
Files
- CHANGELOG.md +4/−0
- haskoin-node.cabal +2/−2
- src/Network/Haskoin/Node/Chain.hs +8/−5
- src/Network/Haskoin/Node/Chain/Logic.hs +53/−16
CHANGELOG.md view
@@ -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.
haskoin-node.cabal view
@@ -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
src/Network/Haskoin/Node/Chain.hs view
@@ -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
src/Network/Haskoin/Node/Chain/Logic.hs view
@@ -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)