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.46.4 +### Fixed +- Do not compute balances separately for loose addresses when part of an xpub. + +### Changed +- Do not fetch entire transaction list for loose addresses. +- Transaction count in wallet object is just a synonym for filtered tx count. +- Use conduits to prevent over-fetching transactions from database. + ## 0.46.3 ### Fixed - Make hex value encoding compatible with Java BigInteger decoder. 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: 1d506c7bd9f5afbe5f0b1da5bd8e173e9ff4ca6f5e64429f1153af50c15ce70b +-- hash: a1382f198453b7795ad226a8857b0e6ad8e5c31f07b52ca38ccd7ecc6eba6035 name: haskoin-store -version: 0.46.3 +version: 0.46.4 synopsis: Storage and index for Bitcoin and Bitcoin Cash description: Please see the README on GitHub at category: Bitcoin, Finance, Network @@ -59,7 +59,7 @@ , hashable >=1.3.0.0 , haskoin-core >=0.19.0 , haskoin-node >=0.17.0 - , haskoin-store-data ==0.46.3 + , haskoin-store-data ==0.46.4 , hedis >=0.12.13 , http-types >=0.12.3 , lens >=4.18.1 @@ -109,7 +109,7 @@ , haskoin-core >=0.19.0 , haskoin-node >=0.17.0 , haskoin-store - , haskoin-store-data ==0.46.3 + , haskoin-store-data ==0.46.4 , hedis >=0.12.13 , http-types >=0.12.3 , lens >=4.18.1 @@ -164,7 +164,7 @@ , haskoin-core >=0.19.0 , haskoin-node >=0.17.0 , haskoin-store - , haskoin-store-data ==0.46.3 + , haskoin-store-data ==0.46.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 @@ -13,8 +13,12 @@ , importBlock , newMempoolTx , deleteUnconfirmedTx + , streamThings + , joinStreams ) where +import Conduit (ConduitT, await, lift, sealConduitT, + yield, ($$++)) import Control.Monad (forM, forM_, guard, unless, void, when, zipWithM_) import Control.Monad.Except (MonadError, throwError) @@ -23,9 +27,11 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Short as B.Short import Data.Either (rights) +import Data.Function (on) import qualified Data.IntMap.Strict as I -import Data.List (nub) -import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing) +import Data.List (nub, sortBy) +import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, + mapMaybe) import Data.Serialize (encode) import Data.Word (Word32, Word64) import Haskoin (Address, Block (..), BlockHash, @@ -162,7 +168,7 @@ action i tx = testPresent tx >>= \case False -> import_it i tx - True -> confirm_it i tx + True -> confirm_it i tx confirm_it i tx = getActiveTxData (txHash tx) >>= \case Just t -> do @@ -577,7 +583,7 @@ spendOutput :: MonadImport m => TxHash -> Word32 -> OutPoint -> m () spendOutput th ix op = do u <- getUnspent op >>= \case - Just u -> return u + Just u -> return u Nothing -> error $ "Could not find UTXO to spend: " <> show op deleteUnspent op insertSpender op (Spender th ix) @@ -596,7 +602,7 @@ unspendOutput op = do t <- getActiveTxData (outPointHash op) >>= \case Nothing -> error $ "Could not find tx data: " <> show (outPointHash op) - Just t -> return t + Just t -> return t let o = fromMaybe (error ("Could not find output: " <> show op)) (getTxOut (outPointIndex op) (txData t)) @@ -669,3 +675,49 @@ testPresent :: StoreReadBase m => Tx -> m Bool testPresent tx = isJust <$> getActiveTxData (txHash tx) + +streamThings :: Monad m + => (Limits -> m [a]) + -> (a -> TxHash) + -> Limits + -> ConduitT () a m () +streamThings f g l = + lift (f l{limit = 50}) >>= \case + [] -> return () + ls -> do + mapM yield ls + go (last ls) + where + go x = + lift (f (Limits 50 0 (Just (AtTx (g x))))) >>= \case + [] -> return () + ls -> do + case dropWhile ((== g x) . g) ls of + [] -> return () + ls' -> do + mapM yield ls' + go (last ls') + +joinStreams :: Monad m + => (a -> a -> Ordering) + -> [ConduitT () a m ()] + -> ConduitT () a m () +joinStreams c xs = do + let ss = map sealConduitT xs + ys <- mapMaybe j <$> + lift (traverse ($$++ await) ss) + go Nothing ys + where + j (x, y) = (,) x <$> y + go m ys = + case sortBy (c `on` snd) ys of + [] -> return () + (i,x):ys' -> do + case m of + Nothing -> yield x + Just x' + | c x x' == EQ -> return () + | otherwise -> yield x + j <$> lift (i $$++ await) >>= \case + Nothing -> go (Just x) ys' + Just y -> go (Just x) (y:ys') diff --git a/src/Haskoin/Store/Web.hs b/src/Haskoin/Store/Web.hs --- a/src/Haskoin/Store/Web.hs +++ b/src/Haskoin/Store/Web.hs @@ -17,8 +17,9 @@ , runWeb ) where -import Conduit (await, runConduit, takeC, yield, - (.|)) +import Conduit (ConduitT, await, dropC, + runConduit, sinkList, takeC, + yield, (.|)) import Control.Applicative ((<|>)) import Control.Arrow (second) import Control.Lens @@ -80,6 +81,7 @@ import Haskoin.Store.Common import Haskoin.Store.Data import Haskoin.Store.Database.Reader +import Haskoin.Store.Logic import Haskoin.Store.Manager import Haskoin.Store.Stats import Haskoin.Store.WebCommon @@ -1304,9 +1306,68 @@ get_xpub_unspents = mapM (`xPubUnspents` def) get_addr_unspents = (`getAddressesUnspents` def) . HashSet.toList +getBinfoTxs :: (StoreReadExtra m, MonadIO m) + => HashMap Address (Maybe BinfoXPubPath) -- address book + -> HashSet XPubSpec -- show xpubs + -> HashSet Address -- show addrs + -> HashSet Address -- balance addresses + -> BinfoFilter + -> Bool -- numtxid + -> Bool -- prune outputs + -> Int64 -- starting balance + -> ConduitT () BinfoTx m () +getBinfoTxs abook sxspecs saddrs baddrs bfilter numtxid prune bal = + joinStreams (flip compare) conduits .| go bal + where + sxspecs_ls = HashSet.toList sxspecs + saddrs_ls = HashSet.toList saddrs + conduits = map xpub_c sxspecs_ls <> map addr_c saddrs_ls + xpub_c x = streamThings (xPubTxs x) txRefHash def + addr_c a = streamThings (getAddressTxs a) txRefHash def + binfo_tx b = toBinfoTx numtxid abook prune b + compute_bal_change BinfoTx{..} = + let ins = mapMaybe getBinfoTxInputPrevOut getBinfoTxInputs + out = getBinfoTxOutputs + f b BinfoTxOutput{..} = + let val = fromIntegral getBinfoTxOutputValue + in case getBinfoTxOutputAddress of + Nothing -> 0 + Just a | a `HashSet.member` baddrs -> + if b then val else negate val + | otherwise -> 0 + in sum $ map (f False) ins <> map (f True) out + go b = await >>= \case + Nothing -> return () + Just (TxRef _ t) -> lift (getTransaction t) >>= \case + Nothing -> go b + Just x -> do + let a = binfo_tx b x + b' = b - compute_bal_change a + c = isJust (getBinfoTxBlockHeight a) + Just (d, _) = getBinfoTxResultBal a + r = d + fromIntegral (getBinfoTxFee a) + case bfilter of + BinfoFilterAll -> + yield a >> go b' + BinfoFilterSent + | 0 > r -> yield a >> go b' + | otherwise -> go b' + BinfoFilterReceived + | r > 0 -> yield a >> go b' + | otherwise -> go b' + BinfoFilterMoved + | r == 0 -> yield a >> go b' + | otherwise -> go b' + BinfoFilterConfirmed + | c -> yield a >> go b' + | otherwise -> go b' + BinfoFilterMempool + | c -> return () + | otherwise -> yield a >> go b' + scottyMultiAddr :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () scottyMultiAddr = - get_addrs >>= \(addrs, xpubs, saddrs, sxpubs, xspecs) -> + get_addrs >>= \(addrs', xpubs, saddrs, sxpubs, xspecs) -> getNumTxId >>= \numtxid -> lift (asks webTicker) >>= \ticker -> get_price ticker >>= \local -> @@ -1315,19 +1376,15 @@ get_count >>= \n -> get_prune >>= \prune -> get_filter >>= \fltr -> - let len = HashSet.size addrs + HashSet.size xpubs + let len = HashSet.size addrs' + HashSet.size xpubs in withMetrics multiaddrResponseTime len $ do xbals <- get_xbals xspecs + xtxns <- mapM count_txs xspecs let sxbals = subset sxpubs xbals - xtrs <- get_xtrs xspecs - let sxtrs = subset sxpubs xtrs - abals <- get_abals addrs - satrs <- get_atrs saddrs - nosatrs <- get_atrs (addrs `HashSet.difference` saddrs) - let xtns = HashMap.map length xtrs - xtrset = Set.fromList (concat (HashMap.elems xtrs)) - sxtrset = Set.fromList (concat (HashMap.elems sxtrs)) xabals = compute_xabals xbals + addrs = addrs' `HashSet.difference` HashMap.keysSet xabals + abals <- get_abals addrs + let sxspecs = compute_sxspecs sxpubs xspecs sxabals = compute_xabals sxbals sabals = subset saddrs abals sallbals = sabals <> sxabals @@ -1335,27 +1392,26 @@ allbals = abals <> xabals abook = compute_abook addrs xbals sxaddrs = compute_xaddrs sxbals - salladdrs = sxaddrs <> saddrs + salladdrs = saddrs <> sxaddrs bal = compute_bal allbals - alltrs = xtrset <> nosatrs <> satrs - salltrs = sxtrset <> satrs - stxids = compute_txids salltrs let ibal = fromIntegral sbal - btxs <- binfo_txs (n + offset) fltr numtxid salladdrs abook prune ibal stxids + ftxs <- + lift . runConduit $ + getBinfoTxs abook sxspecs saddrs salladdrs fltr numtxid prune ibal .| + (dropC offset >> takeC n .| sinkList) best <- get_best_block peers <- get_peers net <- lift $ asks (storeNetwork . webStore . webConfig) - let ftxs = drop offset btxs - baddrs = toBinfoAddrs sabals sxbals xtns - abaddrs = toBinfoAddrs abals xbals xtns + let baddrs = toBinfoAddrs sabals sxbals xtxns + abaddrs = toBinfoAddrs abals xbals xtxns recv = sum $ map getBinfoAddrReceived abaddrs sent = sum $ map getBinfoAddrSent abaddrs - txn = fromIntegral $ Set.size alltrs + txn = fromIntegral $ length ftxs wallet = BinfoWallet { getBinfoWalletBalance = bal , getBinfoWalletTxCount = txn - , getBinfoWalletFilteredCount = fromIntegral (length ftxs) + , getBinfoWalletFilteredCount = txn , getBinfoWalletTotalReceived = recv , getBinfoWalletTotalSent = sent } @@ -1386,6 +1442,7 @@ , getBinfoMultiAddrCashAddr = cashaddr } where + count_txs xspec = length <$> xPubTxs xspec def get_filter = S.param "filter" `S.rescue` const (return BinfoFilterAll) get_best_block = getBestBlock >>= \case @@ -1414,57 +1471,19 @@ return (fromIntegral o :: Int) subset ks = HashMap.filterWithKey (\k _ -> k `HashSet.member` ks) + compute_sxspecs sxpubs = + HashSet.fromList . HashMap.elems . subset sxpubs addr (BinfoAddr a) = Just a addr (BinfoXpub x) = Nothing xpub (BinfoXpub x) = Just x xpub (BinfoAddr _) = Nothing - compute_bal_change addrs BinfoTx{..} = - let ins = mapMaybe getBinfoTxInputPrevOut getBinfoTxInputs - out = getBinfoTxOutputs - f b BinfoTxOutput{..} = - let val = fromIntegral getBinfoTxOutputValue - in case getBinfoTxOutputAddress of - Nothing -> 0 - Just a | a `HashSet.member` addrs -> - if b - then val - else negate val - | otherwise -> 0 - in sum $ map (f False) ins <> map (f True) out - binfo_txs _ _ _ _ _ _ _ [] = return [] - binfo_txs 0 _ _ _ _ _ _ _ = return [] - binfo_txs i f n s o p b (t:ts) = - getTransaction t >>= \case - Nothing -> binfo_txs i f n s o p b ts - Just x -> do - let a = toBinfoTx n o p b x - b' = b - compute_bal_change s a - c = isJust (getBinfoTxBlockHeight a) - Just (d, _) = getBinfoTxResultBal a - r = d + fromIntegral (getBinfoTxFee a) - y = (a:) <$> binfo_txs (i-1) f n s o p b' ts - z = binfo_txs i f n s o p b' ts - case f of - BinfoFilterAll -> y - BinfoFilterSent -> - if r < 0 then y else z - BinfoFilterReceived -> - if r > 0 then y else z - BinfoFilterMoved -> - if r == 0 then y else z - BinfoFilterConfirmed -> - if c then y else z - BinfoFilterMempool -> - if not c then y else return [] get_addrs = do (xspecs, addrs) <- getBinfoActive multiaddrErrors sh <- getBinfoAddrsParam multiaddrErrors "onlyShow" let xpubs = HashMap.keysSet xspecs actives = HashSet.map BinfoAddr addrs <> HashSet.map BinfoXpub xpubs - sh' = if HashSet.null sh - then actives - else sh `HashSet.intersection` actives + sh' = if HashSet.null sh then actives else sh saddrs = HashSet.fromList . mapMaybe addr $ HashSet.toList sh' sxpubs = HashSet.fromList . mapMaybe xpub $ HashSet.toList sh' return (addrs, xpubs, saddrs, sxpubs, xspecs) @@ -1477,21 +1496,6 @@ let f b = (balanceAddress b, b) g = HashMap.fromList . map f in fmap g . getBalances . HashSet.toList - get_xtrs = - let f (k, s) = (,) k <$> xPubTxs s def - in fmap HashMap.fromList . mapM f . HashMap.toList - get_atrs = - let f x = getAddressesTxs x def - in fmap Set.fromList . f . HashSet.toList - get_txs _ _ [] = return [] - get_txs _ 0 _ = return [] - get_txs s n (i:is) = - getTransaction i >>= \case - Nothing -> get_txs s n is - Just t -> - if addr_in_set s t - then ((t, True):) <$> get_txs s (n - 1) is - else ((t, False):) <$> get_txs s n is addr_in_set s t = let f StoreCoinbase{} = False f StoreInput{inputAddress = Nothing} = False