diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,6 +4,14 @@ 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.53.4 +### Added +- Debugging when reverting block. + +### Fixed +- Negative (headers - blocks) diff shown incorrectly. +- Infinite loop when removing a block's coinbase transaction. + ## 0.53.3 ### Added - Blockchain.info endpoint: `q/pubkeyhash/:addr`. 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: b3b7762ba16d37c51367999ec82a9bf98fde10493c5fa48171a6a05ca6e94d45 +-- hash: 5335e9cbdcb9bb2776876aaebeb3be20dfb8c6bcb2a98ab0f6fff39e89f897d9 name: haskoin-store -version: 0.53.3 +version: 0.53.4 synopsis: Storage and index for Bitcoin and Bitcoin Cash description: Please see the README on GitHub at category: Bitcoin, Finance, Network @@ -62,7 +62,7 @@ , hashable >=1.3.0.0 , haskoin-core >=0.20.4 , haskoin-node >=0.17.0 - , haskoin-store-data ==0.53.3 + , haskoin-store-data ==0.53.4 , hedis >=0.12.13 , http-types >=0.12.3 , lens >=4.18.1 @@ -116,7 +116,7 @@ , haskoin-core >=0.20.4 , haskoin-node >=0.17.0 , haskoin-store - , haskoin-store-data ==0.53.3 + , haskoin-store-data ==0.53.4 , hedis >=0.12.13 , http-types >=0.12.3 , lens >=4.18.1 @@ -175,7 +175,7 @@ , haskoin-core >=0.20.4 , haskoin-node >=0.17.0 , haskoin-store - , haskoin-store-data ==0.53.3 + , haskoin-store-data ==0.53.4 , hedis >=0.12.13 , hspec >=2.7.1 , http-types >=0.12.3 diff --git a/src/Haskoin/Store/Logic.hs b/src/Haskoin/Store/Logic.hs --- a/src/Haskoin/Store/Logic.hs +++ b/src/Haskoin/Store/Logic.hs @@ -15,36 +15,36 @@ , deleteUnconfirmedTx ) where -import Conduit (ConduitT, await, lift, sealConduitT, - yield, ($$++)) -import Control.Monad (forM, forM_, guard, unless, void, when, - zipWithM_) -import Control.Monad.Except (MonadError, throwError) -import Control.Monad.Logger (MonadLoggerIO (..), logDebugS, logErrorS) -import qualified Data.ByteString as B -import Data.Either (rights) -import Data.Function (on) -import qualified Data.IntMap.Strict as I -import Data.List (nub, sortBy) -import qualified Data.Map.Strict as Map -import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, - mapMaybe) -import Data.Serialize (encode) -import Data.Word (Word32, Word64) -import Haskoin (Address, Block (..), BlockHash, - BlockHeader (..), BlockNode (..), - Network (..), OutPoint (..), Tx (..), - TxHash, TxIn (..), TxOut (..), - blockHashToHex, computeSubsidy, - eitherToMaybe, genesisBlock, genesisNode, - headerHash, isGenesis, nullOutPoint, - scriptToAddressBS, txHash, txHashToHex) +import Control.Monad (forM, forM_, guard, unless, void, + when, zipWithM_) +import Control.Monad.Except (MonadError, throwError) +import Control.Monad.Logger (MonadLoggerIO (..), logDebugS, + logErrorS) +import qualified Data.ByteString as B +import Data.Either (rights) +import qualified Data.HashSet as HashSet +import qualified Data.IntMap.Strict as I +import Data.List (nub) +import Data.Maybe (catMaybes, fromMaybe, isJust, + isNothing) +import Data.Serialize (encode) +import Data.String.Conversions (cs) +import Data.Word (Word32, Word64) +import Haskoin (Address, Block (..), BlockHash, + BlockHeader (..), BlockNode (..), + Network (..), OutPoint (..), Tx (..), + TxHash, TxIn (..), TxOut (..), + blockHashToHex, computeSubsidy, + eitherToMaybe, genesisBlock, + genesisNode, headerHash, isGenesis, + nullOutPoint, scriptToAddressBS, + txHash, txHashToHex) import Haskoin.Store.Common -import Haskoin.Store.Data (Balance (..), BlockData (..), - BlockRef (..), Prev (..), Spender (..), - TxData (..), TxRef (..), UnixTime, - Unspent (..), confirmed) -import UnliftIO (Exception) +import Haskoin.Store.Data (Balance (..), BlockData (..), + BlockRef (..), Prev (..), + Spender (..), TxData (..), TxRef (..), + UnixTime, Unspent (..), confirmed) +import UnliftIO (Exception) type MonadImport m = ( MonadError ImportException m @@ -91,10 +91,6 @@ $(logDebugS) "BlockStore" "Importing Genesis block" importBlock (genesisBlock net) (genesisNode net) -getOldMempool :: StoreReadBase m => UnixTime -> m [TxHash] -getOldMempool now = - map snd . filter ((< now - 3600 * 72) . fst) <$> getMempool - newMempoolTx :: MonadImport m => Tx -> UnixTime -> m Bool newMempoolTx tx w = getActiveTxData (txHash tx) >>= \case @@ -129,11 +125,24 @@ $(logErrorS) "BlockStore" $ "Cannot revert non-head block: " <> blockHashToHex bh throwError BlockNotBest + $(logDebugS) "BlockStore" $ + "Obtained block data for " <> blockHashToHex bh tds <- mapM getImportTxData (blockDataTxs bd) + $(logDebugS) "BlockStore" $ + "Obtained import tx data for block " <> blockHashToHex bh setBest (prevBlock (blockDataHeader bd)) + $(logDebugS) "BlockStore" $ + "Set parent as best block " <> + blockHashToHex (prevBlock (blockDataHeader bd)) insertBlock bd {blockDataMainChain = False} + $(logDebugS) "BlockStore" $ + "Updated as not in main chain: " <> blockHashToHex bh forM_ (tail tds) unConfirmTx + $(logDebugS) "BlockStore" $ + "Unconfirmed " <> cs (show (length tds)) <> " transactions" deleteConfirmedTx (txHash (txData (head tds))) + $(logDebugS) "BlockStore" $ + "Deleted coinbase: " <> txHashToHex (txHash (txData (head tds))) checkNewBlock :: MonadImport m => Block -> BlockNode -> m () checkNewBlock b n = @@ -399,44 +408,54 @@ -> Bool -- ^ only delete RBF -> TxHash -> m () -deleteTx memonly rbfcheck th = - getChain memonly rbfcheck th >>= - mapM_ (deleteSingleTx . txHash) +deleteTx memonly rbfcheck th = do + chain <- getChain memonly rbfcheck th + $(logDebugS) "BlockStore" $ + "Deleting " <> cs (show (length chain)) <> + " txs from chain leading to " <> txHashToHex th + mapM_ (deleteSingleTx . txHash) chain -getChain :: MonadImport m +getChain :: (MonadImport m, MonadLoggerIO m) => Bool -- ^ only delete transaction if unconfirmed -> Bool -- ^ only delete RBF -> TxHash -> m [Tx] -getChain memonly rbfcheck th = - fmap sort_clean $ - getActiveTxData th >>= \case - Nothing -> do - $(logErrorS) "BlockStore" $ - "Transaction not found: " <> txHashToHex th - throwError TxNotFound - Just td - | memonly && confirmed (txDataBlock td) -> do - $(logErrorS) "BlockStore" $ - "Transaction already confirmed: " - <> txHashToHex th - throwError TxConfirmed - | rbfcheck -> - isRBF (txDataBlock td) (txData td) >>= \case - True -> go td - False -> do - $(logErrorS) "BlockStore" $ - "Double-spending transaction: " - <> txHashToHex th - throwError DoubleSpend - | otherwise -> go td +getChain memonly rbfcheck th' = do + $(logDebugS) "BlockStore" $ + "Getting chain for tx " <> txHashToHex th' + sort_clean <$> go HashSet.empty (HashSet.singleton th') where - sort_clean = reverse . map snd . sortTxs . nub' - go td = do - let tx = txData td - ss <- nub' . map spenderHash . I.elems <$> getSpenders th - xs <- concat <$> mapM (getChain memonly rbfcheck) ss - return $ tx : xs + sort_clean = reverse . map snd . sortTxs + get_tx th = + getActiveTxData th >>= \case + Nothing -> do + $(logErrorS) "BlockStore" $ + "Transaction not found: " <> txHashToHex th + throwError TxNotFound + Just td + | memonly && confirmed (txDataBlock td) -> do + $(logErrorS) "BlockStore" $ + "Transaction already confirmed: " + <> txHashToHex th + throwError TxConfirmed + | rbfcheck -> + isRBF (txDataBlock td) (txData td) >>= \case + True -> return $ txData td + False -> do + $(logErrorS) "BlockStore" $ + "Double-spending transaction: " + <> txHashToHex th + throwError DoubleSpend + | otherwise -> return $ txData td + go txs pdg = do + txs1 <- HashSet.fromList <$> mapM get_tx (HashSet.toList pdg) + pdg1 <- HashSet.fromList . concatMap (map spenderHash . I.elems) <$> + mapM getSpenders (HashSet.toList pdg) + let txs' = txs1 <> txs + pdg' = pdg1 `HashSet.difference` HashSet.map txHash txs' + if HashSet.null pdg' + then return $ HashSet.toList txs' + else go txs' pdg' deleteSingleTx :: MonadImport m => TxHash -> m () deleteSingleTx th =