haskoin-store 0.21.2 → 0.21.3
raw patch · 6 files changed
+91/−98 lines, 6 files
Files
- CHANGELOG.md +5/−0
- haskoin-store.cabal +2/−2
- src/Network/Haskoin/Store/BlockStore.hs +26/−24
- src/Network/Haskoin/Store/CacheWriter.hs +30/−7
- src/Network/Haskoin/Store/Data/CacheReader.hs +2/−39
- src/Network/Haskoin/Store/Logic.hs +26/−26
CHANGELOG.md view
@@ -4,6 +4,11 @@ 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.21.3+### Fixed+- Fix bug where best head was not being registered in cache.+- Fix best head in cache being decoded incorrectly.+ ## 0.21.2 ### Added - Complete support for Redis xpub cache.
haskoin-store.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: b98d31fe2b2c6cc80285d6d64684d5d4e1cd4432ebca24c5ce34f93928b9e933+-- hash: 703917c4565bae5182fdc9a220de64a5b2fd8db190fb70c6297898a91f677dd3 name: haskoin-store-version: 0.21.2+version: 0.21.3 synopsis: Storage and index for Bitcoin and Bitcoin Cash description: Store blocks, transactions, and balances for Bitcoin or Bitcoin Cash, and make that information via REST API. category: Bitcoin, Finance, Network
src/Network/Haskoin/Store/BlockStore.hs view
@@ -168,7 +168,7 @@ net <- asks (blockConfNet . myConfig) runImport (initBest net) >>= \case Left e -> do- $(logErrorS) "Block" $+ $(logErrorS) "BlockStore" $ "Could not initialize block store: " <> fromString (show e) throwIO e Right () -> return ()@@ -183,7 +183,7 @@ isInSync = getBestBlock >>= \case Nothing -> do- $(logErrorS) "Block" "Block database uninitialized"+ $(logErrorS) "BlockStore" "Block database uninitialized" throwIO Uninitialized Just bb -> asks (blockConfChain . myConfig) >>= chainGetBest >>= \cb ->@@ -191,7 +191,7 @@ mempool :: MonadLoggerIO m => Peer -> m () mempool p = do- $(logDebugS) "Block" "Requesting mempool from network peer"+ $(logDebugS) "BlockStore" "Requesting mempool from network peer" MMempool `sendMessage` p processBlock ::@@ -207,13 +207,13 @@ lift (runImport (importBlock net block blocknode)) >>= \case Right deletedtxids -> do listener <- asks (blockConfListener . myConfig)- $(logInfoS) "Block" $ "Best block indexed: " <> hexhash+ $(logInfoS) "BlockStore" $ "Best block indexed: " <> hexhash atomically $ do mapM_ (listener . StoreTxDeleted) deletedtxids listener (StoreBestBlock blockhash) lift (syncMe peer) Left e -> do- $(logErrorS) "Block" $+ $(logErrorS) "BlockStore" $ "Error importing block: " <> hexhash <> ": " <> fromString (show e) killPeer (PeerMisbehaving (show e)) peer@@ -226,13 +226,13 @@ Just Syncing {syncingPeer = syncingpeer} | peer == syncingpeer -> return () _ -> do- $(logErrorS) "Block" $ "Peer sent unexpected block: " <> hexhash+ $(logErrorS) "BlockStore" $ "Peer sent unexpected block: " <> hexhash killPeer (PeerMisbehaving "Sent unpexpected block") peer mzero getblocknode = asks (blockConfChain . myConfig) >>= chainGetBlock blockhash >>= \case Nothing -> do- $(logErrorS) "Block" $ "Block header not found: " <> hexhash+ $(logErrorS) "BlockStore" $ "Block header not found: " <> hexhash killPeer (PeerMisbehaving "Sent unknown block") peer mzero Just n -> return n@@ -243,7 +243,7 @@ -> [BlockHash] -> ReaderT BlockRead m () processNoBlocks p _bs = do- $(logErrorS) "Block" (cs m)+ $(logErrorS) "BlockStore" (cs m) killPeer (PeerMisbehaving m) p where m = "I do not like peers that cannot find them blocks"@@ -257,7 +257,7 @@ runImport (newMempoolTx net tx now) >>= \case Right (Just deleted) -> do l <- blockConfListener <$> asks myConfig- $(logInfoS) "Block" $+ $(logInfoS) "BlockStore" $ "New mempool tx: " <> txHashToHex (txHash tx) atomically $ do mapM_ (l . StoreTxDeleted) deleted@@ -275,7 +275,7 @@ case old of [] -> return () _ -> do- $(logInfoS) "Block" $+ $(logInfoS) "BlockStore" $ "Removing " <> cs (show (length old)) <> " expired orphan transactions" void . runImport $ mapM_ deleteOrphanTx old@@ -283,7 +283,7 @@ case orphans of [] -> return () _ ->- $(logInfoS) "Block" $+ $(logInfoS) "BlockStore" $ "Attempting to import " <> cs (show (length orphans)) <> " orphan transactions" ops <-@@ -317,7 +317,7 @@ guard (isNothing t) return (getTxHash h) unless (null xs) $ do- $(logInfoS) "Block" $+ $(logInfoS) "BlockStore" $ "Requesting " <> fromString (show (length xs)) <> " new transactions" net <- blockConfNet <$> asks myConfig@@ -334,7 +334,7 @@ Just Syncing {syncingTime = t, syncingPeer = p} -> do n <- fromIntegral . systemSeconds <$> liftIO getSystemTime when (n > t + 60) $ do- $(logErrorS) "Block" "Syncing peer timeout"+ $(logErrorS) "BlockStore" "Syncing peer timeout" resetPeer killPeer PeerTimeout p @@ -351,10 +351,10 @@ getPeer >>= \case Nothing -> $(logWarnS)- "Block"+ "BlockStore" "No peers available after syncing peer disconnected" Just peer -> do- $(logWarnS) "Block" "Selected another peer to sync"+ $(logWarnS) "BlockStore" "Selected another peer to sync" syncMe peer | otherwise -> return () @@ -368,7 +368,7 @@ old -> deletetxs old where deletetxs old = do- $(logInfoS) "Block" $+ $(logInfoS) "BlockStore" $ "Removing " <> cs (show (length old)) <> " old mempool transactions" net <- asks (blockConfNet . myConfig) forM_ old $ \txid ->@@ -398,7 +398,7 @@ map (InvVector inv . getBlockHash . headerHash . nodeHeader) blocknodes- $(logInfoS) "Block" $+ $(logInfoS) "BlockStore" $ "Requesting " <> fromString (show (length vectors)) <> " blocks" MGetData (GetData vectors) `sendMessage` peer where@@ -408,20 +408,20 @@ Just Syncing {syncingPeer = p} | p == peer -> return () | otherwise -> do- $(logInfoS) "Block" "Already syncing against another peer"+ $(logInfoS) "BlockStore" "Already syncing against another peer" mzero chainbestnode = chainGetBest =<< asks (blockConfChain . myConfig) bestblocknode = do bb <- lift getBestBlock >>= \case Nothing -> do- $(logErrorS) "Block" "No best block set"+ $(logErrorS) "BlockStore" "No best block set" throwIO Uninitialized Just b -> return b ch <- asks (blockConfChain . myConfig) chainGetBlock bb ch >>= \case Nothing -> do- $(logErrorS) "Block" $+ $(logErrorS) "BlockStore" $ "Header not found for best block: " <> blockHashToHex bb throwIO (BlockNotInChain bb) Just x -> return x@@ -456,7 +456,7 @@ else chainGetAncestor syncheight chainbest ch >>= \case Just x -> return x Nothing -> do- $(logErrorS) "Block" $+ $(logErrorS) "BlockStore" $ "Could not find header for ancestor of block: " <> blockHashToHex (headerHash (nodeHeader chainbest)) throwIO $@@ -468,13 +468,13 @@ ch <- asks (blockConfChain . myConfig) chainBlockMain bestblockhash ch >>= \y -> unless y $ do- $(logErrorS) "Block" $+ $(logErrorS) "BlockStore" $ "Reverting best block: " <> blockHashToHex bestblockhash resetPeer net <- asks (blockConfNet . myConfig) lift (runImport (revertBlock net bestblockhash)) >>= \case Left e -> do- $(logErrorS) "Block" $+ $(logErrorS) "BlockStore" $ "Could not revert best block: " <> cs (show e) throwIO e Right txids -> do@@ -514,7 +514,9 @@ processBlockStoreMessage (BlockNewBest _) = do getPeer >>= \case Nothing -> do- $(logErrorS) "Block" "New best block but no peer to sync from"+ $(logDebugS)+ "BlockStore"+ "New best block event received but no peers available" Just p -> syncMe p processBlockStoreMessage (BlockPeerConnect p _) = syncMe p processBlockStoreMessage (BlockPeerDisconnect p _sa) = processDisconnect p
src/Network/Haskoin/Store/CacheWriter.hs view
@@ -13,11 +13,12 @@ import Control.Monad.Reader (ReaderT (..), asks) import Control.Monad.Trans (lift) import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)+import Data.ByteString (ByteString) import qualified Data.IntMap.Strict as IntMap import Data.List (nub, (\\)) import qualified Data.Map.Strict as Map import Data.Maybe (catMaybes, mapMaybe)-import Data.Serialize (encode)+import Data.Serialize (decode, encode) import Data.String.Conversions (cs) import Database.Redis (RedisCtx, hmset, runRedis, zadd, zrem)@@ -32,6 +33,7 @@ TxOut (..), blockHashToHex, derivePubPath,+ eitherToMaybe, headerHash, pathToList, scriptToAddressBS, txHash, txHashToHex)@@ -60,13 +62,11 @@ CacheReaderConfig (..), CacheReaderT, addrPfx, balancesPfx,- bestBlockKey, blockRefScore, cacheGetXPubBalances,- mempoolSetKey,+ getFromSortedSet, redisGetAddrInfo,- redisGetHead,- redisGetMempool,+ scoreBlockRef, txSetPfx, utxoPfx, withCacheReader) import NQE (Inbox, receive)@@ -109,6 +109,14 @@ runCacheReaderT (xPubTxs xpub start offset limit) getMaxGap = asks (cacheReaderGap . cacheWriterReader) +-- Ordered set of transaction ids in mempool+mempoolSetKey :: ByteString+mempoolSetKey = "mempool"++-- Best block indexed+bestBlockKey :: ByteString+bestBlockKey = "head"+ runCacheReaderT :: StoreRead m => CacheReaderT m a -> CacheWriterT m a runCacheReaderT f = ReaderT (\CacheWriterConfig {cacheWriterReader = r} -> withCacheReader r f)@@ -118,7 +126,7 @@ => CacheWriterConfig -> m () cacheWriter cfg@CacheWriterConfig {cacheWriterMailbox = inbox} =- runReaderT (forever (receive inbox >>= cacheWriterReact)) cfg+ runReaderT (newBlockC >> forever (receive inbox >>= cacheWriterReact)) cfg cacheWriterReact :: (MonadUnliftIO m, MonadLoggerIO m, StoreRead m)@@ -153,7 +161,6 @@ lift getBestBlock >>= \case Nothing -> $(logErrorS) "Cache" "Best block not set yet" Just newhead -> do- $(logErrorS) "Cache" $ "Best block: " <> blockHashToHex newhead cacheGetHead >>= \case Nothing -> do $(logInfoS) "Cache" "Cache has no best block set"@@ -244,6 +251,7 @@ let ths = blockDataTxs bd tds <- sortTxData . catMaybes <$> mapM (lift . getTxData) ths forM_ tds importTxC+ cacheSetHead bh removeHeadC :: (StoreRead m, MonadLoggerIO m) => CacheWriterT m () removeHeadC =@@ -567,3 +575,18 @@ f (Right a) p = Just (a, p) f (Left _) _ = Nothing in catMaybes (zipWith f as ps)++redisGetHead :: (Monad m, Monad f, RedisCtx m f) => m (f (Maybe BlockHash))+redisGetHead = do+ f <- Redis.get bestBlockKey+ return $ (eitherToMaybe . decode =<<) <$> f++redisGetMempool :: (Monad m, Monad f, RedisCtx m f) => m (f [BlockTx])+redisGetMempool = do+ f <- getFromSortedSet mempoolSetKey Nothing 0 Nothing+ return $ do+ bts <- f+ return+ (map (\(t, s) ->+ BlockTx {blockTxBlock = scoreBlockRef s, blockTxHash = t})+ bts)
src/Network/Haskoin/Store/Data/CacheReader.hs view
@@ -25,8 +25,8 @@ zrangebyscoreWithscoresLimit) import qualified Database.Redis as Redis import GHC.Generics (Generic)-import Haskoin (Address, BlockHash, KeyIndex,- OutPoint (..), scriptToAddressBS)+import Haskoin (Address, KeyIndex, OutPoint (..),+ scriptToAddressBS) import Network.Haskoin.Store.Common (Balance (..), BlockRef (..), BlockTx (..), CacheWriter, Limit, Offset, StoreRead (..),@@ -82,21 +82,6 @@ withCacheReader :: StoreRead m => CacheReaderConfig -> CacheReaderT m a -> m a withCacheReader s f = runReaderT f s --- Version of the cache database-cacheVerKey :: ByteString-cacheVerKey = "version"--cacheVerCurrent :: ByteString-cacheVerCurrent = "1"---- Ordered set of transaction ids in mempool-mempoolSetKey :: ByteString-mempoolSetKey = "mempool"---- Best block indexed-bestBlockKey :: ByteString-bestBlockKey = "head"- -- Ordered set of balances for an extended public key balancesPfx :: ByteString balancesPfx = "b"@@ -207,28 +192,6 @@ liftIO (runRedis conn (redisGetXPubUnspents xpub start offset limit)) >>= \case Left e -> throwIO (RedisError e) Right ops -> return ops--redisGetHead :: (Monad m, Monad f, RedisCtx m f) => m (f (Maybe BlockHash))-redisGetHead = do- f <- Redis.get bestBlockKey- return $ do- mbs <- f- case mbs of- Nothing -> return Nothing- Just bs ->- case decode bs of- Left e -> error e- Right h -> return h--redisGetMempool :: (Monad m, Monad f, RedisCtx m f) => m (f [BlockTx])-redisGetMempool = do- f <- getFromSortedSet mempoolSetKey Nothing 0 Nothing- return $ do- bts <- f- return- (map (\(t, s) ->- BlockTx {blockTxBlock = scoreBlockRef s, blockTxHash = t})- bts) redisGetAddrInfo :: (Monad f, RedisCtx m f) => Address -> m (f (Maybe AddressXPub)) redisGetAddrInfo a = do
src/Network/Haskoin/Store/Logic.hs view
@@ -116,7 +116,7 @@ ex (OrphanTx _) = do return Nothing ex _ = do- $(logWarnS) "Block" $+ $(logWarnS) "BlockStore" $ "Deleted bad orphan tx: " <> txHashToHex (txHash tx) deleteOrphanTx (txHash tx) return Nothing@@ -143,7 +143,7 @@ mapM (getTxData . outPointHash . prevOutput) (txIn tx) if orp then do- $(logWarnS) "Block" $ "Orphan tx: " <> txHashToHex (txHash tx)+ $(logWarnS) "BlockStore" $ "Orphan tx: " <> txHashToHex (txHash tx) insertOrphanTx tx w throwError $ OrphanTx (txHashToHex (txHash tx)) else f@@ -167,12 +167,12 @@ then r ds else n r ds = do- $(logWarnS) "Block" $ "Replace by fee tx: " <> txHashToHex (txHash tx)+ $(logWarnS) "BlockStore" $ "Replace by fee tx: " <> txHashToHex (txHash tx) ths <- concat <$> forM ds (deleteTx net True) dts <- importTx net (MemRef w) w tx return (Just (nub (ths <> dts))) n = do- $(logWarnS) "Block" $ "Conflicting tx: " <> txHashToHex (txHash tx)+ $(logWarnS) "BlockStore" $ "Conflicting tx: " <> txHashToHex (txHash tx) insertDeletedMempoolTx tx w return Nothing isrbf th = transactionRBF <$> getImportTx th@@ -190,17 +190,17 @@ bd <- getBestBlock >>= \case Nothing -> do- $(logErrorS) "Block" "Best block unknown"+ $(logErrorS) "BlockStore" "Best block unknown" throwError BestBlockUnknown Just h -> getBlock h >>= \case Nothing -> do- $(logErrorS) "Block" "Best block not found"+ $(logErrorS) "BlockStore" "Best block not found" throwError (BestBlockNotFound (blockHashToHex h)) Just b | h == bh -> return b | otherwise -> do- $(logErrorS) "Block" $+ $(logErrorS) "BlockStore" $ "Cannot delete block that is not head: " <> blockHashToHex h throwError (BlockNotBest (blockHashToHex bh))@@ -228,14 +228,14 @@ Nothing | isGenesis n -> return () | otherwise -> do- $(logErrorS) "Block" $+ $(logErrorS) "BlockStore" $ "Cannot import non-genesis block at this point: " <> blockHashToHex (headerHash (blockHeader b)) throwError BestBlockUnknown Just h | prevBlock (blockHeader b) == h -> return () | otherwise -> do- $(logErrorS) "Block" $+ $(logErrorS) "BlockStore" $ "Block does not build on head: " <> blockHashToHex (headerHash (blockHeader b)) throwError $@@ -267,7 +267,7 @@ then getTxData (txHash tx) >>= \case Just td -> confirmTx net td (br x) tx >> return [] Nothing -> do- $(logErrorS) "Block" $+ $(logErrorS) "BlockStore" $ "Cannot get data for mempool tx: " <> txHashToHex (txHash tx) throwError $ TxNotFound (txHashToHex (txHash tx))@@ -304,11 +304,11 @@ -> m [TxHash] -- ^ deleted transactions importTx net br tt tx = do when (length (nub (map prevOutput (txIn tx))) < length (txIn tx)) $ do- $(logErrorS) "Block" $+ $(logErrorS) "BlockStore" $ "Transaction spends same output twice: " <> txHashToHex (txHash tx) throwError (DuplicatePrevOutput (txHashToHex (txHash tx))) when (iscb && not (confirmed br)) $ do- $(logErrorS) "Block" $+ $(logErrorS) "BlockStore" $ "Coinbase cannot be imported into mempool: " <> txHashToHex (txHash tx) throwError (UnconfirmedCoinbase (txHashToHex (txHash tx)))@@ -321,7 +321,7 @@ when (not (confirmed br) && sum (map unspentAmount us) < sum (map outValue (txOut tx))) $ do- $(logErrorS) "Block" $+ $(logErrorS) "BlockStore" $ "Insufficient funds for tx: " <> txHashToHex (txHash tx) throwError (InsufficientFunds (txHashToHex th)) zipWithM_ (spendOutput net br (txHash tx)) [0 ..] us@@ -354,14 +354,14 @@ getUnspent op >>= \case Just u -> return (u, []) Nothing -> do- $(logWarnS) "Block" $+ $(logWarnS) "BlockStore" $ "Unspent output not found: " <> txHashToHex (outPointHash op) <> " " <> fromString (show (outPointIndex op)) getSpender op >>= \case Nothing -> do- $(logErrorS) "Block" $+ $(logErrorS) "BlockStore" $ "Output not found: " <> txHashToHex (outPointHash op) <> " " <>@@ -371,7 +371,7 @@ ths <- deleteTx net True s getUnspent op >>= \case Nothing -> do- $(logErrorS) "Block" $+ $(logErrorS) "BlockStore" $ "Cannot unspend output: " <> txHashToHex (outPointHash op) <> " " <>@@ -520,14 +520,14 @@ deleteTx net mo h = do getTxData h >>= \case Nothing -> do- $(logErrorS) "Block" $ "Cannot find tx to delete: " <> txHashToHex h+ $(logErrorS) "BlockStore" $ "Cannot find tx to delete: " <> txHashToHex h throwError (TxNotFound (txHashToHex h)) Just t | txDataDeleted t -> do- $(logWarnS) "Block" $ "Already deleted tx: " <> txHashToHex h+ $(logWarnS) "BlockStore" $ "Already deleted tx: " <> txHashToHex h return [] | mo && confirmed (txDataBlock t) -> do- $(logErrorS) "Block" $+ $(logErrorS) "BlockStore" $ "Will not delete confirmed tx: " <> txHashToHex h throwError (TxConfirmed (txHashToHex h)) | otherwise -> go t@@ -580,7 +580,7 @@ in fmap or . forM hs $ \h -> getTxData h >>= \case Nothing -> do- $(logErrorS) "Block" $+ $(logErrorS) "BlockStore" $ "Tx not found: " <> txHashToHex h throwError (TxNotFound (txHashToHex h)) Just t@@ -676,11 +676,11 @@ getImportTx th = getTxData th >>= \case Nothing -> do- $(logErrorS) "Block" $ "Tx not found: " <> txHashToHex th+ $(logErrorS) "BlockStore" $ "Tx not found: " <> txHashToHex th throwError $ TxNotFound (txHashToHex th) Just d | txDataDeleted d -> do- $(logErrorS) "Block" $ "Tx deleted: " <> txHashToHex th+ $(logErrorS) "BlockStore" $ "Tx deleted: " <> txHashToHex th throwError $ TxDeleted (txHashToHex th) | otherwise -> do sm <- getSpenders th@@ -693,7 +693,7 @@ -> m StoreOutput getTxOutput i tx = do unless (fromIntegral i < length (transactionOutputs tx)) $ do- $(logErrorS) "Block" $+ $(logErrorS) "BlockStore" $ "Output out of range: " <> txHashToHex (txHash (transactionData tx)) <> " " <> fromString (show i)@@ -747,7 +747,7 @@ s <- case outputSpender o of Nothing -> do- $(logErrorS) "Block" $+ $(logErrorS) "BlockStore" $ "Output already unspent: " <> txHashToHex (outPointHash op) <> " " <> fromString (show (outPointIndex op))@@ -795,12 +795,12 @@ getBalance a >>= \b -> if nullBalance b then do- $(logErrorS) "Block" $+ $(logErrorS) "BlockStore" $ "Address balance not found: " <> addrText net a throwError (BalanceNotFound (addrText net a)) else do when (v > amnt b) $ do- $(logErrorS) "Block" $+ $(logErrorS) "BlockStore" $ "Insufficient " <> conf <> " balance: " <> addrText net a <> " (needs: " <>