diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. 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: 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 diff --git a/src/Network/Haskoin/Store/BlockStore.hs b/src/Network/Haskoin/Store/BlockStore.hs --- a/src/Network/Haskoin/Store/BlockStore.hs +++ b/src/Network/Haskoin/Store/BlockStore.hs @@ -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 diff --git a/src/Network/Haskoin/Store/CacheWriter.hs b/src/Network/Haskoin/Store/CacheWriter.hs --- a/src/Network/Haskoin/Store/CacheWriter.hs +++ b/src/Network/Haskoin/Store/CacheWriter.hs @@ -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) diff --git a/src/Network/Haskoin/Store/Data/CacheReader.hs b/src/Network/Haskoin/Store/Data/CacheReader.hs --- a/src/Network/Haskoin/Store/Data/CacheReader.hs +++ b/src/Network/Haskoin/Store/Data/CacheReader.hs @@ -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 diff --git a/src/Network/Haskoin/Store/Logic.hs b/src/Network/Haskoin/Store/Logic.hs --- a/src/Network/Haskoin/Store/Logic.hs +++ b/src/Network/Haskoin/Store/Logic.hs @@ -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: " <>