diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,6 +7,7 @@ ## 0.23.16 ### Changed - Better algorithm to avoid importing transaction multiple times in cache. +- Depend on latest Haskoin Node. ## 0.23.15 ### Changed diff --git a/haskoin-store.cabal b/haskoin-store.cabal --- a/haskoin-store.cabal +++ b/haskoin-store.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 0e7fcb134d97933c2fc5c053b4e405331be3381ea5e5af338be91c3b370240f0 +-- hash: 49b9accfed7a4d474c7a08471883565ad6a24898bf560190503132a33eba11c6 name: haskoin-store -version: 0.23.15 +version: 0.23.16 synopsis: Storage and index for Bitcoin and Bitcoin Cash description: Store and index Bitcoin or Bitcoin Cash blocks, transactions, balances and unspent outputs. All data is available via REST API in JSON or binary format. @@ -59,7 +59,7 @@ , deepseq >=1.4.4.0 , hashable >=1.3.0.0 , haskoin-core >=0.12.0 - , haskoin-node >=0.9.21 + , haskoin-node >=0.10.0 , hedis >=0.12.13 , http-types >=0.12.3 , monad-logger >=0.3.32 @@ -148,7 +148,7 @@ , deepseq >=1.4.4.0 , hashable >=1.3.0.0 , haskoin-core >=0.12.0 - , haskoin-node >=0.9.21 + , haskoin-node >=0.10.0 , hedis >=0.12.13 , hspec >=2.7.1 , http-types >=0.12.3 diff --git a/src/Haskoin/Store/BlockStore.hs b/src/Haskoin/Store/BlockStore.hs --- a/src/Haskoin/Store/BlockStore.hs +++ b/src/Haskoin/Store/BlockStore.hs @@ -42,9 +42,10 @@ chainBlockMain, chainGetAncestor, chainGetBest, chainGetBlock, chainGetParents, - killPeer, managerGetPeers, - sendMessage) -import Haskoin.Node (Chain, Manager, managerGetPeer) + killPeer, managerGetPeer, + managerGetPeers, sendMessage) +import Haskoin.Node (Chain, PeerManager, + managerPeerText) import Haskoin.Store.Common (BlockStore, BlockStoreMessage (..), BlockTx (..), StoreEvent (..), @@ -101,7 +102,7 @@ -- | Configuration for a block store. data BlockStoreConfig = BlockStoreConfig - { blockConfManager :: !Manager + { blockConfManager :: !PeerManager -- ^ peer manager from running node , blockConfChain :: !Chain -- ^ chain from a running node @@ -227,10 +228,12 @@ void . runMaybeT $ do checkpeer blocknode <- getblocknode + p' <- managerPeerText peer =<< asks (blockConfManager . myConfig) lift (runImport (importBlock block blocknode)) >>= \case Right deletedtxids -> do listener <- asks (blockConfListener . myConfig) - $(logInfoS) "BlockStore" $ "Best block indexed: " <> hexhash + $(logInfoS) "BlockStore" $ + "Best block indexed: " <> hexhash <> " from peer " <> p' atomically $ do mapM_ (listener . StoreTxDeleted) deletedtxids listener (StoreBestBlock blockhash) @@ -238,24 +241,43 @@ Left e -> do $(logErrorS) "BlockStore" $ "Error importing block: " <> hexhash <> ": " <> - fromString (show e) + fromString (show e) <> + " from peer " <> + p' killPeer (PeerMisbehaving (show e)) peer where header = blockHeader block blockhash = headerHash header hexhash = blockHashToHex blockhash - checkpeer = - getSyncingState >>= \case - Just Syncing {syncingPeer = syncingpeer} - | peer == syncingpeer -> return () - _ -> do - $(logErrorS) "BlockStore" $ "Peer sent unexpected block: " <> hexhash - killPeer (PeerMisbehaving "Sent unpexpected block") peer + checkpeer = do + pm <- managerGetPeer peer =<< asks (blockConfManager . myConfig) + case pm of + Nothing -> do + $(logWarnS) "BlockStore" $ + "Ignoring block " <> hexhash <> " from disconnected peer" mzero + Just _ -> + getSyncingState >>= \case + Just Syncing {syncingPeer = syncingpeer} + | peer == syncingpeer -> return () + _ -> do + p' <- + managerPeerText peer =<< + asks (blockConfManager . myConfig) + $(logDebugS) "BlockStore" $ + "Ignoring block " <> hexhash <> + " from non-syncing peer " <> + p' + killPeer (PeerMisbehaving "Sent unpexpected block") peer + mzero getblocknode = asks (blockConfChain . myConfig) >>= chainGetBlock blockhash >>= \case Nothing -> do - $(logErrorS) "BlockStore" $ "Block header not found: " <> hexhash + p' <- + managerPeerText peer =<< asks (blockConfManager . myConfig) + $(logErrorS) "BlockStore" $ + "Header not found for block " <> hexhash <> " sent by peer " <> + p' killPeer (PeerMisbehaving "Sent unknown block") peer mzero Just n -> return n @@ -265,15 +287,22 @@ => Peer -> [BlockHash] -> ReaderT BlockRead m () -processNoBlocks p _bs = do - $(logErrorS) "BlockStore" (cs m) - killPeer (PeerMisbehaving m) p - where - m = "I do not like peers that cannot find them blocks" +processNoBlocks p hs = do + p' <- managerPeerText p =<< asks (blockConfManager . myConfig) + forM_ (zip [(1 :: Int) ..] hs) $ \(i, h) -> + $(logErrorS) "BlockStore" $ + "Block " <> cs (show i) <> "/" <> cs (show (length hs)) <> " " <> + blockHashToHex h <> + " not found by peer " <> + p' + killPeer (PeerMisbehaving "Did not find requested block(s)") p processTx :: (MonadUnliftIO m, MonadLoggerIO m) => Peer -> Tx -> BlockT m () -processTx _p tx = do +processTx p tx = do t <- fromIntegral . systemSeconds <$> liftIO getSystemTime + p' <- managerPeerText p =<< asks (blockConfManager . myConfig) + $(logDebugS) "BlockManager" $ + "Received tx " <> txHashToHex (txHash tx) <> " from peer " <> p' addPendingTx $ PendingTx t tx HashSet.empty pruneOrphans :: MonadIO m => BlockT m () @@ -406,14 +435,32 @@ processTxs p hs = do sync <- isInSync when sync $ do + p' <- managerPeerText p =<< asks (blockConfManager . myConfig) + $(logDebugS) "BlockStore" $ + "Received inventory with " <> cs (show (length hs)) <> + " transactions from peer " <> + p' xs <- - fmap catMaybes . forM hs $ \h -> + fmap catMaybes . forM (zip [(1 :: Int) ..] hs) $ \(i, h) -> haveit h >>= \case True -> do $(logDebugS) "BlockStore" $ - "Ignoring already downloaded tx: " <> txHashToHex h + "Already have tx " <> cs (show i) <> "/" <> + cs (show (length hs)) <> + " " <> + txHashToHex h <> + " offered by peer " <> + p' return Nothing - False -> return (Just h) + False -> do + $(logInfoS) "BlockStore" $ + "Requesting transaction " <> cs (show i) <> "/" <> + cs (show (length hs)) <> + " " <> + txHashToHex h <> + " from peer " <> + p' + return (Just h) unless (null xs) $ go xs where haveit h = @@ -424,19 +471,6 @@ Nothing -> return False Just txd -> return (not (txDataDeleted txd)) go xs = do - p' <- - do mgr <- asks (blockConfManager . myConfig) - managerGetPeer p mgr >>= \case - Nothing -> return "???" - Just op -> return . cs . show $ onlinePeerAddress op - forM_ (zip [(1 :: Int) ..] xs) $ \(i, h) -> - $(logInfoS) "BlockStore" $ - "Requesting transaction " <> cs (show i) <> "/" <> - cs (show (length xs)) <> - " " <> - txHashToHex h <> - " from peer " <> - p' net <- asks (blockConfNet . myConfig) let inv = if getSegWit net @@ -451,7 +485,8 @@ Just Syncing {syncingTime = t, syncingPeer = p} -> do n <- fromIntegral . systemSeconds <$> liftIO getSystemTime when (n > t + 60) $ do - $(logErrorS) "BlockStore" "Syncing peer timeout" + p' <- managerPeerText p =<< asks (blockConfManager . myConfig) + $(logErrorS) "BlockStore" $ "Timeout syncing peer " <> p' resetPeer killPeer PeerTimeout p @@ -464,14 +499,16 @@ Nothing -> return () Just Syncing {syncingPeer = p'} | p == p' -> do + $(logWarnS) "BlockStore" "Syncing peer disconnected" resetPeer getPeer >>= \case - Nothing -> - $(logWarnS) - "BlockStore" - "No peers available after syncing peer disconnected" + Nothing -> do + $(logWarnS) "BlockStore" "No new syncing peer available" Just peer -> do - $(logWarnS) "BlockStore" "Selected another peer to sync" + ns <- + managerPeerText peer =<< + asks (blockConfManager . myConfig) + $(logWarnS) "BlockStore" $ "New syncing peer " <> ns syncMe peer | otherwise -> return () @@ -485,9 +522,11 @@ old -> deletetxs old where deletetxs old = do - $(logInfoS) "BlockStore" $ - "Removing " <> cs (show (length old)) <> " old mempool transactions" - forM_ old $ \txid -> + forM_ (zip [(1 :: Int) ..] old) $ \(i, txid) -> do + $(logInfoS) "BlockStore" $ + "Removing " <> cs (show i) <> "/" <> cs (show (length old)) <> + " old mempool tx " <> + txHashToHex txid runImport (deleteTx True False txid) >>= \case Left _ -> return () Right txids -> do @@ -514,8 +553,19 @@ map (InvVector inv . getBlockHash . headerHash . nodeHeader) blocknodes + p' <- managerPeerText peer =<< asks (blockConfManager . myConfig) $(logInfoS) "BlockStore" $ - "Requesting " <> fromString (show (length vectors)) <> " blocks" + "Requesting " <> fromString (show (length vectors)) <> + " blocks from peer " <> + p' + forM_ (zip [(1 :: Int) ..] blocknodes) $ \(i, bn) -> do + $(logDebugS) "BlockStore" $ + "Requesting block " <> cs (show i) <> "/" <> + cs (show (length vectors)) <> + ": " <> + blockHashToHex (headerHash (nodeHeader bn)) <> + " from peer " <> + p' MGetData (GetData vectors) `sendMessage` peer where checksyncingpeer = @@ -523,9 +573,7 @@ Nothing -> return () Just Syncing {syncingPeer = p} | p == peer -> return () - | otherwise -> do - $(logInfoS) "BlockStore" "Already syncing against another peer" - mzero + | otherwise -> mzero chainbestnode = chainGetBest =<< asks (blockConfChain . myConfig) bestblocknode = do bb <- @@ -626,12 +674,9 @@ (MonadUnliftIO m, MonadLoggerIO m) => BlockStoreMessage -> BlockT m () -processBlockStoreMessage (BlockNewBest _) = do +processBlockStoreMessage (BlockNewBest _) = getPeer >>= \case - Nothing -> do - $(logDebugS) - "BlockStore" - "New best block event received but no peers available" + Nothing -> return () Just p -> syncMe p processBlockStoreMessage (BlockPeerConnect p _) = syncMe p processBlockStoreMessage (BlockPeerDisconnect p _sa) = processDisconnect p diff --git a/src/Haskoin/Store/Manager.hs b/src/Haskoin/Store/Manager.hs --- a/src/Haskoin/Store/Manager.hs +++ b/src/Haskoin/Store/Manager.hs @@ -18,7 +18,7 @@ VarString (..), sockToHostAddress) import Haskoin.Node (Chain, ChainEvent (..), - HostPort, Manager, + HostPort, PeerManager, NodeConfig (..), NodeEvent (..), PeerEvent (..), node) import Haskoin.Store.BlockStore (BlockStoreConfig (..), @@ -45,7 +45,7 @@ -- | Store mailboxes. data Store = Store - { storeManager :: !Manager + { storeManager :: !PeerManager , storeChain :: !Chain , storeBlock :: !BlockStore , storeDB :: !DatabaseReader diff --git a/src/Haskoin/Store/Web.hs b/src/Haskoin/Store/Web.hs --- a/src/Haskoin/Store/Web.hs +++ b/src/Haskoin/Store/Web.hs @@ -62,9 +62,9 @@ hexToBlockHash, hexToTxHash, stringToAddr, txHash, xPubImport) -import Haskoin.Node (Chain, Manager, OnlinePeer (..), - chainGetBest, managerGetPeers, - sendMessage) +import Haskoin.Node (Chain, OnlinePeer (..), + PeerManager, chainGetBest, + managerGetPeers, sendMessage) import Haskoin.Store.Cache (CacheT, delXPubKeys, withCache) import Haskoin.Store.Common (BlockData (..), BlockRef (..), BlockTx (..), DeriveType (..), @@ -956,7 +956,7 @@ healthCheck :: (MonadUnliftIO m, StoreRead m) => Network - -> Manager + -> PeerManager -> Chain -> WebTimeouts -> m HealthCheck @@ -1023,7 +1023,7 @@ compute_delta a b = if b > a then b - a else 0 -- | Obtain information about connected peers from peer manager process. -getPeersInformation :: MonadIO m => Manager -> m [PeerInformation] +getPeersInformation :: MonadIO m => PeerManager -> m [PeerInformation] getPeersInformation mgr = mapMaybe toInfo <$> managerGetPeers mgr where toInfo op = do @@ -1149,7 +1149,7 @@ (MonadUnliftIO m, StoreRead m) => Network -> Publisher StoreEvent - -> Manager + -> PeerManager -> Tx -> m (Either PubExcept ()) publishTx net pub mgr tx =