diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,6 +4,15 @@ 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.15.2 +### Added +- Internal data types to support orphan transactions. + +### Changed +- Do not spam block actor with pings. +- Fix balance/unspent cache not reverting when importing fails. +- Fix transaction sorting algorithm not including transaction position information. + ## 0.15.1 ### Changed - Fix duplicate coinbase transaction id bug. 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: e7b8e1136ee2c05c5f2395b5c1b3b5cf6375e519fce16db05a7d0d3df7c487f5 +-- hash: f789909b15a88fd2b0d4a03016ad5b760ac4a7b2a246a8c19e133598c5940dc0 name: haskoin-store -version: 0.15.1 +version: 0.15.2 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/Block.hs b/src/Network/Haskoin/Store/Block.hs --- a/src/Network/Haskoin/Store/Block.hs +++ b/src/Network/Haskoin/Store/Block.hs @@ -163,6 +163,11 @@ runExceptT (runImportDB db um bm $ importBlock net b n) >>= \case Right () -> do l <- blockConfListener <$> asks myConfig + $(logInfoS) "Block" $ + "Best block indexed: " <> + blockHashToHex (headerHash (blockHeader b)) <> + " at height " <> + cs (show (nodeHeight n)) atomically $ l (StoreBestBlock (headerHash (blockHeader b))) lift $ isSynced >>= \x -> when x (mempool p) when (nodeHeight n `mod` 1000 == 0) (lift pruneCache) @@ -183,7 +188,9 @@ if nodeHeader h == blockHeader b then resetPeer else do - now <- fromIntegral . systemSeconds <$> liftIO getSystemTime + now <- + fromIntegral . systemSeconds <$> + liftIO getSystemTime asks myPeer >>= atomically . (`writeTVar` Just s {syncingTime = now}) @@ -448,11 +455,11 @@ processBlockMessage (BlockNotFound p bs) = processNoBlocks p bs processBlockMessage (BlockTxReceived p tx) = processTx p tx processBlockMessage (BlockTxAvailable p ts) = processTxs p ts -processBlockMessage BlockPing = checkTime +processBlockMessage (BlockPing r) = checkTime >> atomically (r ()) processBlockMessage PurgeMempool = purgeMempool pingMe :: MonadLoggerIO m => Mailbox BlockMessage -> m () pingMe mbox = forever $ do threadDelay =<< liftIO (randomRIO (5 * 1000 * 1000, 10 * 1000 * 1000)) - $(logDebugS) "Block" "Pinging block" - BlockPing `send` mbox + $(logDebugS) "BlockTimer" "Pinging block" + BlockPing `query` mbox diff --git a/src/Network/Haskoin/Store/Data.hs b/src/Network/Haskoin/Store/Data.hs --- a/src/Network/Haskoin/Store/Data.hs +++ b/src/Network/Haskoin/Store/Data.hs @@ -63,6 +63,7 @@ getBlocksAtHeight :: BlockHeight -> m [BlockHash] getBlock :: BlockHash -> m (Maybe BlockData) getTxData :: TxHash -> m (Maybe TxData) + getOrphanTx :: TxHash -> m (Maybe (UnixTime, Tx)) getSpenders :: TxHash -> m (IntMap Spender) getSpender :: OutPoint -> m (Maybe Spender) @@ -75,6 +76,7 @@ class StoreStream m where getMempool :: Maybe UnixTime -> ConduitT () (UnixTime, TxHash) m () + getOrphans :: ConduitT () (UnixTime, Tx) m () getAddressUnspents :: Address -> Maybe BlockRef -> ConduitT () Unspent m () getAddressTxs :: Address -> Maybe BlockRef -> ConduitT () BlockTx m () @@ -92,6 +94,8 @@ removeAddrUnspent :: Address -> Unspent -> m () insertMempoolTx :: TxHash -> UnixTime -> m () deleteMempoolTx :: TxHash -> UnixTime -> m () + insertOrphanTx :: Tx -> UnixTime -> m () + deleteOrphanTx :: TxHash -> m () -- | Serialize such that ordering is inverted. putUnixTime w = putWord64be $ maxBound - w diff --git a/src/Network/Haskoin/Store/Data/ImportDB.hs b/src/Network/Haskoin/Store/Data/ImportDB.hs --- a/src/Network/Haskoin/Store/Data/ImportDB.hs +++ b/src/Network/Haskoin/Store/Data/ImportDB.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} module Network.Haskoin.Store.Data.ImportDB where import Conduit @@ -41,17 +41,22 @@ -> m a runImportDB db um bm f = do hm <- newTVarIO emptyHashMapDB + um' <- atomically $ readTVar um >>= newTVar + bm' <- atomically $ readTVar bm >>= newTVar x <- R.runReaderT f ImportDB { importRocksDB = (defaultReadOptions, db) , importHashMap = hm - , importUnspentMap = um - , importBalanceMap = bm + , importUnspentMap = um' + , importBalanceMap = bm' } ops <- hashMapOps <$> readTVarIO hm writeBatch db ops + atomically $ do + readTVar um' >>= writeTVar um + readTVar bm' >>= writeTVar bm return x hashMapOps :: HashMapDB -> [BatchOp] @@ -65,6 +70,7 @@ addrTxOps (hAddrTx db) <> addrOutOps (hAddrOut db) <> mempoolOps (hMempool db) <> + orphanOps (hOrphans db) <> unspentOps (hUnspent db) bestBlockOp :: Maybe BlockHash -> [BatchOp] @@ -148,6 +154,12 @@ g u t True = insertOp (MemKey u t) () g u t False = deleteOp (MemKey u t) +orphanOps :: HashMap TxHash (Maybe (UnixTime, Tx)) -> [BatchOp] +orphanOps = map (uncurry f) . M.toList + where + f h (Just x) = insertOp (OrphanKey h) x + f h Nothing = deleteOp (OrphanKey h) + unspentOps :: HashMap TxHash (IntMap (Maybe Unspent)) -> [BatchOp] unspentOps = concatMap (uncurry f) . M.toList where @@ -219,6 +231,14 @@ deleteMempoolTxI t p ImportDB {importHashMap = hm} = atomically . withBlockSTM hm $ deleteMempoolTx t p +insertOrphanTxI :: MonadIO m => Tx -> UnixTime -> ImportDB -> m () +insertOrphanTxI t p ImportDB {importHashMap = hm} = + atomically . withBlockSTM hm $ insertOrphanTx t p + +deleteOrphanTxI :: MonadIO m => TxHash -> ImportDB -> m () +deleteOrphanTxI t ImportDB {importHashMap = hm} = + atomically . withBlockSTM hm $ deleteOrphanTx t + getBestBlockI :: MonadIO m => ImportDB -> m (Maybe BlockHash) getBestBlockI ImportDB {importHashMap = hm, importRocksDB = db} = runMaybeT $ MaybeT f <|> MaybeT g @@ -247,6 +267,13 @@ f = atomically . withBlockSTM hm $ getTxData th g = uncurry withBlockDB db $ getTxData th +getOrphanTxI :: MonadIO m => TxHash -> ImportDB -> m (Maybe (UnixTime, Tx)) +getOrphanTxI h ImportDB {importRocksDB = db, importHashMap = hm} = + fmap join . runMaybeT $ MaybeT f <|> MaybeT g + where + f = getOrphanTxH h <$> readTVarIO hm + g = Just <$> uncurry withBlockDB db (getOrphanTx h) + getSpenderI :: MonadIO m => OutPoint -> ImportDB -> m (Maybe Spender) getSpenderI op ImportDB {importRocksDB = db, importHashMap = hm} = getSpenderH op <$> readTVarIO hm >>= \case @@ -311,6 +338,7 @@ getTxData t = R.ask >>= getTxDataI t getSpender p = R.ask >>= getSpenderI p getSpenders t = R.ask >>= getSpendersI t + getOrphanTx h = R.ask >>= getOrphanTxI h instance (MonadIO m) => StoreWrite (ReaderT ImportDB m) where setInit = R.ask >>= setInitI @@ -326,6 +354,8 @@ removeAddrUnspent a u = R.ask >>= removeAddrUnspentI a u insertMempoolTx t p = R.ask >>= insertMempoolTxI t p deleteMempoolTx t p = R.ask >>= deleteMempoolTxI t p + insertOrphanTx t p = R.ask >>= insertOrphanTxI t p + deleteOrphanTx t = R.ask >>= deleteOrphanTxI t instance (MonadIO m) => UnspentRead (ReaderT ImportDB m) where getUnspent a = R.ask >>= getUnspentI a diff --git a/src/Network/Haskoin/Store/Data/KeyValue.hs b/src/Network/Haskoin/Store/Data/KeyValue.hs --- a/src/Network/Haskoin/Store/Data/KeyValue.hs +++ b/src/Network/Haskoin/Store/Data/KeyValue.hs @@ -193,11 +193,12 @@ deriving (Show, Read, Eq, Ord, Generic, Hashable) instance Serialize MemKey where - -- 0x07 · TxHash + -- 0x07 · UnixTime · TxHash put (MemKey t h) = do putWord8 0x07 putUnixTime t put h + -- 0x07 · UnixTime put (MemKeyT t) = do putWord8 0x07 putUnixTime t @@ -209,6 +210,29 @@ instance R.Key MemKey instance R.KeyValue MemKey () + +-- | Orphan pool transaction database key. +data OrphanKey + = OrphanKey + { orphanKey :: !TxHash + } + | OrphanKeyS + deriving (Show, Read, Eq, Ord, Generic, Hashable) + +instance Serialize OrphanKey + -- 0x08 · TxHash + where + put (OrphanKey h) = do + putWord8 0x08 + put h + -- 0x08 + put OrphanKeyS = putWord8 0x08 + get = do + guard . (== 0x08) =<< getWord8 + OrphanKey <$> get + +instance R.Key OrphanKey +instance R.KeyValue OrphanKey (UnixTime, Tx) -- | Block entry database key. newtype BlockKey = BlockKey diff --git a/src/Network/Haskoin/Store/Data/RocksDB.hs b/src/Network/Haskoin/Store/Data/RocksDB.hs --- a/src/Network/Haskoin/Store/Data/RocksDB.hs +++ b/src/Network/Haskoin/Store/Data/RocksDB.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -Wno-orphans #-} module Network.Haskoin.Store.Data.RocksDB where @@ -100,6 +100,17 @@ f (MemKey u t) () = (u, t) f _ _ = undefined +getOrphansDB :: + (MonadIO m, MonadResource m) + => ReadOptions + -> DB + -> ConduitT () (UnixTime, Tx) m () +getOrphansDB opts db = matching db opts OrphanKeyS .| mapC snd + +getOrphanTxDB :: + MonadIO m => TxHash -> ReadOptions -> DB -> m (Maybe (UnixTime, Tx)) +getOrphanTxDB h opts db = retrieve db opts (OrphanKey h) + getAddressTxsDB :: (MonadIO m, MonadResource m) => Address @@ -162,10 +173,12 @@ getTxData t = R.ask >>= uncurry (getTxDataDB t) getSpenders p = R.ask >>= uncurry (getSpendersDB p) getSpender p = R.ask >>= uncurry (getSpenderDB p) + getOrphanTx h = R.ask >>= uncurry (getOrphanTxDB h) instance (MonadIO m, MonadResource m) => StoreStream (ReaderT BlockDB m) where getMempool p = lift R.ask >>= uncurry (getMempoolDB p) + getOrphans = lift R.ask >>= uncurry getOrphansDB getAddressTxs a b = R.ask >>= uncurry (getAddressTxsDB a b) getAddressUnspents a b = R.ask >>= uncurry (getAddressUnspentsDB a b) diff --git a/src/Network/Haskoin/Store/Data/STM.hs b/src/Network/Haskoin/Store/Data/STM.hs --- a/src/Network/Haskoin/Store/Data/STM.hs +++ b/src/Network/Haskoin/Store/Data/STM.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -Wno-orphans #-} module Network.Haskoin.Store.Data.STM where @@ -46,6 +46,7 @@ , hAddrTx :: !(HashMap Address (HashMap BlockRef (HashMap TxHash Bool))) , hAddrOut :: !(HashMap Address (HashMap BlockRef (HashMap OutPoint (Maybe OutVal)))) , hMempool :: !(HashMap UnixTime (HashMap TxHash Bool)) + , hOrphans :: !(HashMap TxHash (Maybe (UnixTime, Tx))) , hInit :: !Bool } deriving (Eq, Show) @@ -62,6 +63,7 @@ , hAddrTx = M.empty , hAddrOut = M.empty , hMempool = M.empty + , hOrphans = M.empty , hInit = False } @@ -118,6 +120,12 @@ hMempool db in yieldMany [(u, h) | (u, hs) <- ls, h <- hs] +getOrphansH :: Monad m => HashMapDB -> ConduitT () (UnixTime, Tx) m () +getOrphansH = yieldMany . catMaybes . M.elems . hOrphans + +getOrphanTxH :: TxHash -> HashMapDB -> Maybe (Maybe (UnixTime, Tx)) +getOrphanTxH h = M.lookup h . hOrphans + getAddressTxsH :: Address -> Maybe BlockRef -> HashMapDB -> [BlockTx] getAddressTxsH a mbr db = dropWhile h . @@ -264,6 +272,13 @@ let s = M.singleton u (M.singleton h False) in db {hMempool = M.unionWith M.union s (hMempool db)} +insertOrphanTxH :: Tx -> UnixTime -> HashMapDB -> HashMapDB +insertOrphanTxH tx u db = + db {hOrphans = M.insert (txHash tx) (Just (u, tx)) (hOrphans db)} + +deleteOrphanTxH :: TxHash -> HashMapDB -> HashMapDB +deleteOrphanTxH h db = db {hOrphans = M.insert h Nothing (hOrphans db)} + getUnspentH :: OutPoint -> HashMapDB -> Maybe (Maybe Unspent) getUnspentH op db = do m <- M.lookup (outPointHash op) (hUnspent db) @@ -305,6 +320,7 @@ fmap (I.map fromJust . I.filter isJust . getSpendersH t) . lift . readTVar =<< R.ask + getOrphanTx h = fmap (join . getOrphanTxH h) . lift . readTVar =<< R.ask instance BalanceRead BlockSTM where getBalance a = fmap (getBalanceH a) . lift . readTVar =<< R.ask @@ -318,6 +334,7 @@ instance StoreStream BlockSTM where getMempool m = getMempoolH m =<< lift . lift . readTVar =<< lift R.ask + getOrphans = getOrphansH =<< lift . lift . readTVar =<< lift R.ask getAddressTxs a m = yieldMany . getAddressTxsH a m =<< lift . lift . readTVar =<< lift R.ask getAddressUnspents a m = @@ -340,6 +357,8 @@ lift . (`modifyTVar` removeAddrUnspentH a u) =<< R.ask insertMempoolTx h t = lift . (`modifyTVar` insertMempoolTxH h t) =<< R.ask deleteMempoolTx h t = lift . (`modifyTVar` deleteMempoolTxH h t) =<< R.ask + deleteOrphanTx h = lift . (`modifyTVar` deleteOrphanTxH h) =<< R.ask + insertOrphanTx t u = lift . (`modifyTVar` insertOrphanTxH t u) =<< R.ask instance UnspentWrite BlockSTM where addUnspent h = lift . (`modifyTVar` addUnspentH h) =<< R.ask 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 @@ -179,7 +179,7 @@ blockHashToHex h throwError (BlockNotBest bh) txs <- mapM (fmap transactionData . getImportTx) (blockDataTxs bd) - mapM_ (deleteTx net False . txHash) (reverse (sortTxs txs)) + mapM_ (deleteTx net False . txHash . snd) (reverse (sortTxs txs)) setBest (prevBlock (blockDataHeader bd)) insertBlock bd {blockDataMainChain = False} @@ -233,14 +233,22 @@ } insertAtHeight (headerHash (nodeHeader n)) (nodeHeight n) setBest (headerHash (nodeHeader n)) - zipWithM_ import_or_confirm [0 ..] (sortTxs (blockTxns b)) + $(logDebugS) "Block" $ "Importing or confirming block transactions..." + mapM_ (uncurry import_or_confirm) (sortTxs (blockTxns b)) + $(logDebugS) "Block" $ + "Done importing transactions for block " <> + blockHashToHex (headerHash (nodeHeader n)) where import_or_confirm x tx = getTxData (txHash tx) >>= \case Just t - | x > 0 && not (txDataDeleted t) -> confirmTx net t (br x) tx - _ -> - importTx net (br x) (fromIntegral (blockTimestamp (nodeHeader n))) tx + | x > 0 && not (txDataDeleted t) -> do confirmTx net t (br x) tx + _ -> do + importTx + net + (br x) + (fromIntegral (blockTimestamp (nodeHeader n))) + tx subsidy = computeSubsidy net cb_out_val = sum (map outValue (txOut (head (blockTxns b)))) ts_out_val = sum (map (sum . map outValue . txOut) (tail (blockTxns b))) @@ -256,14 +264,18 @@ x = B.length (encode b) in s * 3 + x -sortTxs :: [Tx] -> [Tx] -sortTxs [] = [] -sortTxs txs = is <> sortTxs ds +sortTxs :: [Tx] -> [(Word32, Tx)] +sortTxs txs = go $ zip [0 ..] txs where - (is, ds) = - partition - (all ((`notElem` map txHash txs) . outPointHash . prevOutput) . txIn) - txs + go [] = [] + go ts = + let (is, ds) = + partition + (all ((`notElem` map (txHash . snd) ts) . + outPointHash . prevOutput) . + txIn . snd) + ts + in is <> go ds importTx :: ( MonadError ImportException m @@ -291,7 +303,6 @@ txHashToHex (txHash tx) throwError (UnconfirmedCoinbase (txHash tx)) us <- - fromMaybe [] . sequence <$> if iscb then return [] else forM (txIn tx) $ \TxIn {prevOutput = op} -> uns op @@ -302,7 +313,7 @@ "Insufficient funds: " <> txHashToHex (txHash tx) throwError (InsufficientFunds th) zipWithM_ (spendOutput net br (txHash tx)) [0 ..] us - zipWithM_ (newOutput br . OutPoint (txHash tx)) [0 ..] (txOut tx) + zipWithM_ (newOutput net br . OutPoint (txHash tx)) [0 ..] (txOut tx) rbf <- getrbf let t = Transaction @@ -325,13 +336,31 @@ where uns op = getUnspent op >>= \case + Just u -> return u Nothing -> do - $(logErrorS) "BlockLogic" $ + $(logWarnS) "BlockLogic" $ "No unspent output: " <> txHashToHex (outPointHash op) <> " " <> fromString (show (outPointIndex op)) - throwError (NoUnspent op) - Just u -> return $ Just u + getSpender op >>= \case + Nothing -> do + $(logErrorS) "BlockLogic" $ + "No spent or unspent output: " <> + txHashToHex (outPointHash op) <> + " " <> + fromString (show (outPointIndex op)) + throwError (NoUnspent op) + Just Spender {spenderHash = s} -> do + deleteTx net True s + getUnspent op >>= \case + Nothing -> do + $(logErrorS) "BlockLogic" $ + "Could not unspend output: " <> + txHashToHex (outPointHash op) <> + " " <> + fromString (show (outPointIndex op)) + throwError (NoUnspent op) + Just u -> return u th = txHash tx iscb = all (== nullOutPoint) (map prevOutput (txIn tx)) ws = map Just (txWitness tx) <> repeat Nothing @@ -387,31 +416,14 @@ -> Tx -> m () confirmTx net t br tx = do - $(logDebugS) "BlockLogic" $ - "Confirming tx " <> txHashToHex (txHash tx) <> " previously on " <> - cs (show (txDataBlock t)) <> - " and now on " <> - cs (show br) forM_ (txDataPrevs t) $ \p -> case scriptToAddressBS (prevScript p) of Left _ -> return () Right a -> do - $(logDebugS) "BlockLogic" $ - "Removing tx " <> txHashToHex (txHash tx) <> - " from address " <> - fromMaybe "???" (addrToString net a) <> - " on " <> - cs (show (txDataBlock t)) removeAddrTx a BlockTx {blockTxBlock = txDataBlock t, blockTxHash = txHash tx} - $(logDebugS) "BlockLogic" $ "Inserting tx " <> - txHashToHex (txHash tx) <> - " for address " <> - fromMaybe "???" (addrToString net a) <> - " on " <> - cs (show br) insertAddrTx a BlockTx {blockTxBlock = br, blockTxHash = txHash tx} @@ -430,22 +442,10 @@ case scriptToAddressBS (scriptOutput o) of Left _ -> return () Right a -> do - $(logDebugS) "BlockLogic" $ - "Removing tx " <> txHashToHex (txHash tx) <> - " from address " <> - fromMaybe "???" (addrToString net a) <> - " on " <> - cs (show (txDataBlock t)) removeAddrTx a BlockTx {blockTxBlock = txDataBlock t, blockTxHash = txHash tx} - $(logDebugS) "BlockLogic" $ "Inserting tx " <> - txHashToHex (txHash tx) <> - " for address " <> - fromMaybe "???" (addrToString net a) <> - " on " <> - cs (show br) insertAddrTx a BlockTx {blockTxBlock = br, blockTxHash = txHash tx} @@ -467,7 +467,7 @@ , unspentScript = B.Short.toShort (scriptOutput o) } reduceBalance net False False a (outValue o) - increaseBalance True False a (outValue o) + increaseBalance net True False a (outValue o) insertTx t {txDataBlock = br} deleteMempoolTx (txHash tx) (memRefTime (txDataBlock t)) @@ -521,7 +521,7 @@ forM_ (take (length (txOut (txData t))) [0 ..]) $ \n -> delOutput net (OutPoint h n) let ps = filter (/= nullOutPoint) (map prevOutput (txIn (txData t))) - mapM_ unspendOutput ps + mapM_ (unspendOutput net) ps unless (confirmed (txDataBlock t)) $ deleteMempoolTx h (memRefTime (txDataBlock t)) insertTx t {txDataDeleted = True} @@ -598,11 +598,12 @@ , BalanceWrite m , MonadLogger m ) - => BlockRef + => Network + -> BlockRef -> OutPoint -> TxOut -> m () -newOutput br op to = do +newOutput net br op to = do addUnspent u case scriptToAddressBS (scriptOutput to) of Left _ -> return () @@ -614,7 +615,7 @@ { blockTxHash = outPointHash op , blockTxBlock = br } - increaseBalance (confirmed br) True a (outValue to) + increaseBalance net (confirmed br) True a (outValue to) where u = Unspent @@ -751,9 +752,10 @@ , BalanceWrite m , MonadLogger m ) - => OutPoint + => Network + -> OutPoint -> m () -unspendOutput op = do +unspendOutput net op = do t <- getImportTx (outPointHash op) o <- getTxOutput (outPointIndex op) t s <- @@ -786,6 +788,7 @@ , blockTxBlock = transactionBlock x } increaseBalance + net (confirmed (unspentBlock u)) False a @@ -805,24 +808,20 @@ -> Address -> Word64 -> m () -reduceBalance net c t a v = +reduceBalance net c t a v = do getBalance a >>= \case Nothing -> do - $(logErrorS) "BlockLogic" $ "Balance not found: " <> addrText net a + $(logErrorS) "BlockLogic" $ + "Balance not found for address " <> addrText net a throwError (BalanceNotFound a) Just b -> do - when - (v > - if c - then balanceAmount b - else balanceZero b) $ do + when (v > amnt b) $ do $(logErrorS) "BlockLogic" $ - "Insufficient " <> - (if c - then "confirmed " - else "unconfirmed ") <> - "balance: " <> - addrText net a + "Insufficient " <> conf <> " balance: " <> addrText net a <> + " (needs: " <> + cs (show v) <> + ", has: " <> + cs (show (amnt b)) <> ")" throwError $ if c then InsufficientBalance a @@ -846,6 +845,19 @@ then v else 0 } + where + amnt = + if c + then balanceAmount + else balanceZero + conf = + if c + then "confirmed" + else "unconfirmed" + addr = + case addrToString net a of + Nothing -> "???" + Just x -> x increaseBalance :: ( MonadError ImportException m @@ -855,12 +867,13 @@ , BalanceWrite m , MonadLogger m ) - => Bool -- ^ add confirmed output + => Network + -> Bool -- ^ add confirmed output -> Bool -- ^ increase total received -> Address -> Word64 -> m () -increaseBalance c t a v = do +increaseBalance _net c t a v = do b <- getBalance a >>= \case Nothing -> @@ -893,6 +906,11 @@ then v else 0 } + where + conf = + if c + then "confirmed" + else "unconfirmed" updateAddressCounts :: (MonadError ImportException m, BalanceWrite m, BalanceRead m) @@ -921,4 +939,4 @@ map (scriptToAddressBS . scriptOutput) (txOut (txData t)) addrText :: Network -> Address -> Text -addrText net a = fromMaybe "[unreprestable]" $ addrToString net a +addrText net a = fromMaybe "???" $ addrToString net a diff --git a/src/Network/Haskoin/Store/Messages.hs b/src/Network/Haskoin/Store/Messages.hs --- a/src/Network/Haskoin/Store/Messages.hs +++ b/src/Network/Haskoin/Store/Messages.hs @@ -76,7 +76,7 @@ | BlockTxAvailable !Peer ![TxHash] -- ^ peer has transactions available - | BlockPing + | BlockPing !(Listen ()) -- ^ internal housekeeping ping | PurgeMempool -- ^ purge mempool transactions