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.56.0 +### Changed +- Report all deleted mempool transactions. +- Crash on certain data corruption. + ## 0.55.0 ### Changed - Always have a previous output object in Blockchain inputs. diff --git a/haskoin-store.cabal b/haskoin-store.cabal --- a/haskoin-store.cabal +++ b/haskoin-store.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: haskoin-store -version: 0.55.0 +version: 0.56.0 synopsis: Storage and index for Bitcoin and Bitcoin Cash description: Please see the README on GitHub at category: Bitcoin, Finance, Network @@ -60,7 +60,7 @@ , hashable >=1.3.0.0 , haskoin-core >=0.21.0 , haskoin-node >=0.17.0 - , haskoin-store-data ==0.55.0 + , haskoin-store-data ==0.56.0 , hedis >=0.12.13 , http-types >=0.12.3 , lens >=4.18.1 @@ -116,7 +116,7 @@ , haskoin-core >=0.21.0 , haskoin-node >=0.17.0 , haskoin-store - , haskoin-store-data ==0.55.0 + , haskoin-store-data ==0.56.0 , hedis >=0.12.13 , http-types >=0.12.3 , lens >=4.18.1 @@ -177,7 +177,7 @@ , haskoin-core >=0.21.0 , haskoin-node >=0.17.0 , haskoin-store - , haskoin-store-data ==0.55.0 + , haskoin-store-data ==0.56.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 @@ -391,15 +391,15 @@ <> " from peer: " <> peerText peer lift $ runImport (importBlock block node) >>= \case Left e -> failure e - Right () -> success node + Right ths -> success node ths where header = blockHeader block blockhash = headerHash header hexhash = blockHashToHex blockhash - success node = do + success node ths = do $(logInfoS) "BlockStore" $ "Best block: " <> blockText node (Just block) - notify + notify ths removeSyncingBlock $ headerHash $ nodeHeader node touchPeer isInSync >>= \case @@ -413,8 +413,9 @@ <> " from peer: " <> peerText peer <> ": " <> cs (show e) killPeer (PeerMisbehaving (show e)) peer - notify = do + notify ths = do listener <- asks (blockConfListener . myConfig) + mapM_ ((`publish` listener) . StoreMempoolDelete) ths publish (StoreBestBlock blockhash) listener setSyncingBlocks :: (MonadReader BlockStore m, MonadIO m) 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 @@ -16,7 +16,7 @@ ) where import Control.Monad (forM, forM_, guard, unless, void, - when, zipWithM_) + when, zipWithM_, (<=<)) import Control.Monad.Except (MonadError, throwError) import Control.Monad.Logger (MonadLoggerIO (..), logDebugS, logErrorS) @@ -67,6 +67,7 @@ | DuplicatePrevOutput | TxSpent | OrphanLoop + | SpenderNotFound deriving (Eq, Ord, Exception) instance Show ImportException where @@ -82,6 +83,7 @@ show DuplicatePrevOutput = "Duplicate previous output" show TxSpent = "Transaction is spent" show OrphanLoop = "Orphan loop" + show SpenderNotFound = "Spender not found" initBest :: MonadImport m => m () initBest = do @@ -166,10 +168,11 @@ <> blockHashToHex (headerHash (blockHeader b)) throwError PrevBlockNotBest -importOrConfirm :: MonadImport m => BlockNode -> [Tx] -> m () +importOrConfirm :: MonadImport m => BlockNode -> [Tx] -> m (HashSet TxHash) importOrConfirm bn txns = do - mapM_ (freeOutputs True False . snd) (reverse txs) + ths <- foldl (<>) HashSet.empty <$> mapM (freeOutputs True False . snd) (reverse txs) mapM_ (uncurry action) txs + return ths where txs = sortTxs txns br i = BlockRef {blockRefHeight = nodeHeight bn, blockRefPos = i} @@ -197,7 +200,7 @@ importTx (br i) bn_time False tx return Nothing -importBlock :: MonadImport m => Block -> BlockNode -> m () +importBlock :: MonadImport m => Block -> BlockNode -> m (HashSet TxHash) importBlock b n = do $(logDebugS) "BlockStore" $ "Checking new block: " @@ -227,10 +230,11 @@ (nub (headerHash (nodeHeader n) : bs)) (nodeHeight n) setBest (headerHash (nodeHeader n)) - importOrConfirm n (blockTxns b) + ths <- importOrConfirm n (blockTxns b) $(logDebugS) "BlockStore" $ "Finished importing transactions for: " <> blockHashToHex (headerHash (nodeHeader n)) + return ths where cb_out_val = sum $ map outValue $ txOut $ head $ blockTxns b @@ -394,32 +398,37 @@ let prevs = prevOuts tx unspents <- mapM getUnspent prevs let spents = map fst $ filter (isNothing . snd) $ zip prevs unspents - spndrs <- catMaybes <$> mapM getSpender spents + spndrs <- mapM (spender <=< getSpender) spents let txids = HashSet.fromList $ filter (/= txHash tx) $ map spenderHash spndrs - mapM (deleteTx memonly rbfcheck) $ HashSet.toList txids - return txids + del <- fmap concat $ mapM (deleteTx memonly rbfcheck) $ HashSet.toList txids + return $ HashSet.fromList del + where + spender Nothing = throwError SpenderNotFound + spender (Just s) = return s -deleteConfirmedTx :: MonadImport m => TxHash -> m () +deleteConfirmedTx :: MonadImport m => TxHash -> m [TxHash] deleteConfirmedTx = deleteTx False False -deleteUnconfirmedTx :: MonadImport m => Bool -> TxHash -> m () +deleteUnconfirmedTx :: MonadImport m => Bool -> TxHash -> m [TxHash] deleteUnconfirmedTx rbfcheck th = getActiveTxData th >>= \case Just _ -> deleteTx True rbfcheck th - Nothing -> $(logDebugS) "BlockStore" $ - "Not found or already deleted: " <> txHashToHex th + Nothing -> do + $(logDebugS) "BlockStore" $ + "Not found or already deleted: " <> txHashToHex th + return [] deleteTx :: MonadImport m => Bool -- ^ only delete transaction if unconfirmed -> Bool -- ^ only delete RBF -> TxHash - -> m () + -> m [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 + mapM (\t -> let h = txHash t in deleteSingleTx h >> return h) chain getChain :: (MonadImport m, MonadLoggerIO m) => Bool -- ^ only delete transaction if unconfirmed