haskoin-store 0.23.15 → 0.23.16
raw patch · 5 files changed
+112/−66 lines, 5 filesdep ~haskoin-node
Dependency ranges changed: haskoin-node
Files
- CHANGELOG.md +1/−0
- haskoin-store.cabal +4/−4
- src/Haskoin/Store/BlockStore.hs +99/−54
- src/Haskoin/Store/Manager.hs +2/−2
- src/Haskoin/Store/Web.hs +6/−6
CHANGELOG.md view
@@ -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
haskoin-store.cabal view
@@ -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
src/Haskoin/Store/BlockStore.hs view
@@ -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
src/Haskoin/Store/Manager.hs view
@@ -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
src/Haskoin/Store/Web.hs view
@@ -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 =