haskoin-store 0.51.0 → 0.52.0
raw patch · 10 files changed
+349/−424 lines, 10 filesdep ~haskoin-store-dataPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: haskoin-store-data
API changes (from Hackage documentation)
- Haskoin.Store: [cacheThreads] :: CacheConfig -> !CacheThreads
- Haskoin.Store: [storeConfCacheThreads] :: StoreConfig -> !Int
- Haskoin.Store.Cache: [cacheThreads] :: CacheConfig -> !CacheThreads
- Haskoin.Store.Cache: newCacheThreads :: MonadIO m => Int -> m CacheThreads
- Haskoin.Store.Common: xPubBalsTxs :: StoreReadExtra m => [XPubBal] -> Limits -> m [TxRef]
- Haskoin.Store.Common: xPubBalsUnspents :: StoreReadExtra m => [XPubBal] -> Limits -> m [XPubUnspent]
- Haskoin.Store.Logic: joinDescStreams :: (Monad m, Ord a) => [ConduitT () a m ()] -> ConduitT () a m ()
- Haskoin.Store.Logic: streamThings :: Monad m => (Limits -> m [a]) -> (a -> TxHash) -> Limits -> ConduitT () a m ()
- Haskoin.Store.Manager: [storeConfCacheThreads] :: StoreConfig -> !Int
- Haskoin.Store.Web: [webRequests] :: WebConfig -> !Int
+ Haskoin.Store.Common: applyLimit :: Limit -> [a] -> [a]
+ Haskoin.Store.Common: applyLimitC :: Monad m => Limit -> ConduitT i i m ()
+ Haskoin.Store.Common: joinDescStreams :: (Monad m, Ord a) => [ConduitT () a m ()] -> ConduitT () a m ()
+ Haskoin.Store.Common: streamThings :: Monad m => (Limits -> m [a]) -> Maybe (a -> TxHash) -> Limits -> ConduitT () a m ()
- Haskoin.Store: CacheConfig :: !Connection -> !Int -> !Integer -> !Chain -> !Int -> !Int -> !Maybe CacheMetrics -> !CacheThreads -> CacheConfig
+ Haskoin.Store: CacheConfig :: !Connection -> !Int -> !Integer -> !Chain -> !Int -> !Int -> !Maybe CacheMetrics -> CacheConfig
- Haskoin.Store: StoreConfig :: !Int -> ![HostPort] -> !Bool -> !FilePath -> !Network -> !Maybe String -> !Word32 -> !Word32 -> !Int -> !Integer -> !Bool -> !Bool -> !NominalDiffTime -> !NominalDiffTime -> !SockAddr -> WithConnection -> !Int -> !Int -> !Maybe Store -> !Int -> StoreConfig
+ Haskoin.Store: StoreConfig :: !Int -> ![HostPort] -> !Bool -> !FilePath -> !Network -> !Maybe String -> !Word32 -> !Word32 -> !Int -> !Integer -> !Bool -> !Bool -> !NominalDiffTime -> !NominalDiffTime -> !SockAddr -> WithConnection -> !Int -> !Int -> !Maybe Store -> StoreConfig
- Haskoin.Store: xPubSummary :: StoreReadExtra m => XPubSpec -> m XPubSummary
+ Haskoin.Store: xPubSummary :: StoreReadExtra m => XPubSpec -> [XPubBal] -> m XPubSummary
- Haskoin.Store: xPubTxCount :: StoreReadExtra m => XPubSpec -> m Word32
+ Haskoin.Store: xPubTxCount :: StoreReadExtra m => XPubSpec -> [XPubBal] -> m Word32
- Haskoin.Store: xPubTxs :: StoreReadExtra m => XPubSpec -> Limits -> m [TxRef]
+ Haskoin.Store: xPubTxs :: StoreReadExtra m => XPubSpec -> [XPubBal] -> Limits -> m [TxRef]
- Haskoin.Store: xPubUnspents :: StoreReadExtra m => XPubSpec -> Limits -> m [XPubUnspent]
+ Haskoin.Store: xPubUnspents :: StoreReadExtra m => XPubSpec -> [XPubBal] -> Limits -> m [XPubUnspent]
- Haskoin.Store.Cache: CacheConfig :: !Connection -> !Int -> !Integer -> !Chain -> !Int -> !Int -> !Maybe CacheMetrics -> !CacheThreads -> CacheConfig
+ Haskoin.Store.Cache: CacheConfig :: !Connection -> !Int -> !Integer -> !Chain -> !Int -> !Int -> !Maybe CacheMetrics -> CacheConfig
- Haskoin.Store.Common: xPubSummary :: StoreReadExtra m => XPubSpec -> m XPubSummary
+ Haskoin.Store.Common: xPubSummary :: StoreReadExtra m => XPubSpec -> [XPubBal] -> m XPubSummary
- Haskoin.Store.Common: xPubTxCount :: StoreReadExtra m => XPubSpec -> m Word32
+ Haskoin.Store.Common: xPubTxCount :: StoreReadExtra m => XPubSpec -> [XPubBal] -> m Word32
- Haskoin.Store.Common: xPubTxs :: StoreReadExtra m => XPubSpec -> Limits -> m [TxRef]
+ Haskoin.Store.Common: xPubTxs :: StoreReadExtra m => XPubSpec -> [XPubBal] -> Limits -> m [TxRef]
- Haskoin.Store.Common: xPubUnspents :: StoreReadExtra m => XPubSpec -> Limits -> m [XPubUnspent]
+ Haskoin.Store.Common: xPubUnspents :: StoreReadExtra m => XPubSpec -> [XPubBal] -> Limits -> m [XPubUnspent]
- Haskoin.Store.Manager: StoreConfig :: !Int -> ![HostPort] -> !Bool -> !FilePath -> !Network -> !Maybe String -> !Word32 -> !Word32 -> !Int -> !Integer -> !Bool -> !Bool -> !NominalDiffTime -> !NominalDiffTime -> !SockAddr -> WithConnection -> !Int -> !Int -> !Maybe Store -> !Int -> StoreConfig
+ Haskoin.Store.Manager: StoreConfig :: !Int -> ![HostPort] -> !Bool -> !FilePath -> !Network -> !Maybe String -> !Word32 -> !Word32 -> !Int -> !Integer -> !Bool -> !Bool -> !NominalDiffTime -> !NominalDiffTime -> !SockAddr -> WithConnection -> !Int -> !Int -> !Maybe Store -> StoreConfig
- Haskoin.Store.Web: WebConfig :: !String -> !Int -> !Store -> !Int -> !Int -> !WebLimits -> !WebTimeouts -> !String -> !Bool -> !Maybe Store -> !Int -> !Int -> WebConfig
+ Haskoin.Store.Web: WebConfig :: !String -> !Int -> !Store -> !Int -> !Int -> !WebLimits -> !WebTimeouts -> !String -> !Bool -> !Maybe Store -> !Int -> WebConfig
Files
- CHANGELOG.md +9/−0
- app/Main.hs +0/−32
- haskoin-store.cabal +5/−5
- src/Haskoin/Store/Cache.hs +104/−110
- src/Haskoin/Store/Common.hs +108/−81
- src/Haskoin/Store/Database/Reader.hs +18/−22
- src/Haskoin/Store/Logic.hs +0/−44
- src/Haskoin/Store/Manager.hs +3/−8
- src/Haskoin/Store/Web.hs +102/−121
- test/Haskoin/StoreSpec.hs +0/−1
CHANGELOG.md view
@@ -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.52.0+### Changed+- Remove unnecessary performance optimisations.++### Fixed+- Reduce balance retrievals for xpubs.+- Hack UTXO ordering to avoid unwanted behaviours.+- Do not merge conduits when there are too many.+ ## 0.51.0 ### Fixed - Data type for RequestTooLarge was missing.
app/Main.hs view
@@ -79,9 +79,7 @@ , configStatsdHost :: !String , configStatsdPort :: !Int , configStatsdPrefix :: !String- , configWebRequests :: !Int , configWebPriceGet :: !Int- , configCacheThreads :: !Int } instance Default Config where@@ -113,9 +111,7 @@ , configStatsdHost = defStatsdHost , configStatsdPort = defStatsdPort , configStatsdPrefix = defStatsdPrefix- , configWebRequests = defWebRequests , configWebPriceGet = defWebPriceGet- , configCacheThreads = defCacheThreads } defEnv :: MonadIO m => String -> a -> (String -> Maybe a) -> m a@@ -270,16 +266,6 @@ defEnv "STATSD_PORT" 8125 readMaybe {-# NOINLINE defStatsdPort #-} -defWebRequests :: Int-defWebRequests = unsafePerformIO $- defEnv "WEB_REQUESTS" 32 readMaybe-{-# NOINLINE defWebRequests #-}--defCacheThreads :: Int-defCacheThreads = unsafePerformIO $- defEnv "CACHE_THREADS" 8 readMaybe-{-# NOINLINE defCacheThreads #-}- defWebPriceGet :: Int defWebPriceGet = unsafePerformIO $ defEnv "WEB_PRICE_GET" (90 * 1000 * 1000) readMaybe@@ -536,13 +522,6 @@ <> help "Prefix for statsd metrics" <> showDefault <> value (configStatsdPrefix def)- configWebRequests <-- option auto $- metavar "INT"- <> long "web-requests"- <> help "Simultaneous web requests"- <> showDefault- <> value (configWebRequests def) configWebPriceGet <- option auto $ metavar "MICROSECONDS"@@ -550,13 +529,6 @@ <> help "How often to retrieve price information" <> showDefault <> value (configWebPriceGet def)- configCacheThreads <-- option auto $- metavar "INT"- <> long "cache-threads"- <> help "Number of simultaneous xpub caching threads"- <> showDefault- <> value (configCacheThreads def) pure Config { configWebLimits = WebLimits {..}@@ -633,9 +605,7 @@ , configStatsdHost = statsdhost , configStatsdPort = statsdport , configStatsdPrefix = statsdpfx- , configWebRequests = wreqs , configWebPriceGet = wpget- , configCacheThreads = cth } = runStderrLoggingT . filterLogger l . with_stats $ \stats -> do $(logInfoS) "Main" $@@ -665,7 +635,6 @@ , storeConfCacheRefresh = crefresh , storeConfCacheRetryDelay = cretrydelay , storeConfStats = stats- , storeConfCacheThreads = cth } withStore scfg $ \st -> runWeb@@ -680,7 +649,6 @@ , webMaxDiff = maxdiff , webNoMempool = nomem , webStats = stats- , webRequests = wreqs , webPriceGet = wpget } where
haskoin-store.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: cf0e99fca7630779bc98f41b4e1ee7cb2b98c1a6e0285a2a817eeb1100560cd9+-- hash: 78e1694f8db6dab25d0a46bec8ac4221798c460aa51eb92f60c674676fb773fa name: haskoin-store-version: 0.51.0+version: 0.52.0 synopsis: Storage and index for Bitcoin and Bitcoin Cash description: Please see the README on GitHub at <https://github.com/haskoin/haskoin-store#readme> category: Bitcoin, Finance, Network@@ -61,7 +61,7 @@ , hashable >=1.3.0.0 , haskoin-core >=0.19.0 , haskoin-node >=0.17.0- , haskoin-store-data ==0.51.0+ , haskoin-store-data ==0.52.0 , hedis >=0.12.13 , http-types >=0.12.3 , lens >=4.18.1@@ -115,7 +115,7 @@ , haskoin-core >=0.19.0 , haskoin-node >=0.17.0 , haskoin-store- , haskoin-store-data ==0.51.0+ , haskoin-store-data ==0.52.0 , hedis >=0.12.13 , http-types >=0.12.3 , lens >=4.18.1@@ -174,7 +174,7 @@ , haskoin-core >=0.19.0 , haskoin-node >=0.17.0 , haskoin-store- , haskoin-store-data ==0.51.0+ , haskoin-store-data ==0.52.0 , hedis >=0.12.13 , hspec >=2.7.1 , http-types >=0.12.3
src/Haskoin/Store/Cache.hs view
@@ -15,7 +15,6 @@ , CacheT , CacheError(..) , newCacheMetrics- , newCacheThreads , withCache , connectRedis , blockRefScore@@ -35,10 +34,11 @@ import Control.Monad.Reader (ReaderT (..), ask, asks) import Control.Monad.Trans (lift) import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)-import Data.Bits (shift, (.&.), (.|.))+import Data.Bits (complement, shift, (.&.), (.|.)) import Data.ByteString (ByteString)+import qualified Data.ByteString as B import Data.Default (def)-import Data.Either (rights)+import Data.Either (fromRight, isRight, rights) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.HashSet (HashSet)@@ -117,14 +117,8 @@ , cacheRefresh :: !Int -- millisenconds , cacheRetryDelay :: !Int -- microseconds , cacheMetrics :: !(Maybe CacheMetrics)- , cacheThreads :: !CacheThreads } -type CacheThreads = TVar Int--newCacheThreads :: MonadIO m => Int -> m CacheThreads-newCacheThreads = newTVarIO- data CacheMetrics = CacheMetrics { cacheHits :: !Metrics.Counter , cacheMisses :: !Metrics.Counter@@ -220,25 +214,33 @@ getAddressTxs addr = lift . getAddressTxs addr getAddressUnspents addr = lift . getAddressUnspents addr getAddressesUnspents addrs = lift . getAddressesUnspents addrs+ getMaxGap = lift getMaxGap+ getInitialGap = lift getInitialGap+ getNumTxData = lift . getNumTxData xPubBals xpub = ask >>= \case- Nothing -> lift (xPubBals xpub)- Just cfg -> lift (runReaderT (getXPubBalances xpub) cfg)- xPubUnspents xpub limits =+ Nothing -> lift $+ xPubBals xpub+ Just cfg -> lift $+ runReaderT (getXPubBalances xpub) cfg+ xPubUnspents xpub xbals limits = ask >>= \case- Nothing -> lift (xPubUnspents xpub limits)- Just cfg -> lift (runReaderT (getXPubUnspents xpub limits) cfg)- xPubTxs xpub limits =+ Nothing -> lift $+ xPubUnspents xpub xbals limits+ Just cfg -> lift $+ runReaderT (getXPubUnspents xpub xbals limits) cfg+ xPubTxs xpub xbals limits = ask >>= \case- Nothing -> lift (xPubTxs xpub limits)- Just cfg -> lift (runReaderT (getXPubTxs xpub limits) cfg)- xPubTxCount xpub =+ Nothing -> lift $+ xPubTxs xpub xbals limits+ Just cfg -> lift $+ runReaderT (getXPubTxs xpub xbals limits) cfg+ xPubTxCount xpub xbals = ask >>= \case- Nothing -> lift (xPubTxCount xpub)- Just cfg -> lift (runReaderT (getXPubTxCount xpub) cfg)- getMaxGap = lift getMaxGap- getInitialGap = lift getInitialGap- getNumTxData = lift . getNumTxData+ Nothing -> lift $+ xPubTxCount xpub xbals+ Just cfg -> lift $+ runReaderT (getXPubTxCount xpub xbals) cfg withCache :: StoreReadBase m => Maybe CacheConfig -> CacheT m a -> m a withCache s f = runReaderT f s@@ -257,24 +259,24 @@ getXPubTxs :: (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m)- => XPubSpec -> Limits -> CacheX m [TxRef]-getXPubTxs xpub limits = go Nothing+ => XPubSpec -> [XPubBal] -> Limits -> CacheX m [TxRef]+getXPubTxs xpub xbals limits = go False where go m = isXPubCached xpub >>= \case True -> do- when (isNothing m) $ incrementCounter cacheHits+ unless m $ incrementCounter cacheHits cacheGetXPubTxs xpub limits False -> case m of- Just bals -> lift $ xPubBalsTxs bals limits- Nothing -> do- bals <- lift $ xPubBals xpub- newXPubC xpub bals- go (Just bals)+ True -> lift $ xPubTxs xpub xbals limits+ False -> do+ newXPubC xpub xbals+ go True getXPubTxCount :: (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m)- => XPubSpec -> CacheX m Word32-getXPubTxCount xpub = go False+ => XPubSpec -> [XPubBal] -> CacheX m Word32+getXPubTxCount xpub xbals =+ go False where go t = isXPubCached xpub >>= \case True -> do@@ -282,43 +284,49 @@ cacheGetXPubTxCount xpub False -> if t- then lift $ xPubTxCount xpub+ then lift $ xPubTxCount xpub xbals else do- bals <- lift $ xPubBals xpub- newXPubC xpub bals+ newXPubC xpub xbals go True -getXPubUnspents ::- (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m)- => XPubSpec -> Limits -> CacheX m [XPubUnspent]-getXPubUnspents xpub limits = go Nothing+getXPubUnspents :: (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m)+ => XPubSpec -> [XPubBal] -> Limits -> CacheX m [XPubUnspent]+getXPubUnspents xpub xbals limits =+ go False where+ xm = let f x = (balanceAddress (xPubBal x), x)+ g = (> 0) . balanceUnspentCount . xPubBal+ in HashMap.fromList $ map f $ filter g xbals go m = isXPubCached xpub >>= \case True -> do- when (isNothing m) $ incrementCounter cacheHits- process =<< cacheGetXPubBalances xpub+ unless m $ incrementCounter cacheHits+ process False -> case m of- Just bals -> lift $ xPubBalsUnspents bals limits- Nothing -> do- bals <- lift $ xPubBals xpub- newXPubC xpub bals- go (Just bals)- process bals = do+ True ->+ lift $ xPubUnspents xpub xbals limits+ False -> do+ newXPubC xpub xbals+ go True+ process = do ops <- map snd <$> cacheGetXPubUnspents xpub limits uns <- catMaybes <$> lift (mapM getUnspent ops)- let g b = (balanceAddress (xPubBal b), xPubBalPath b)- addrmap = Map.fromList (map g bals)- f u = either+ let f u = either (const Nothing) (\a -> Just (a, u)) (scriptToAddressBS (unspentScript u))- addrutxo = mapMaybe f uns- e (a, u) = (`XPubUnspent` u) <$> Map.lookup a addrmap- return $ mapMaybe e addrutxo+ g a = HashMap.lookup a xm+ h u x =+ XPubUnspent+ {+ xPubUnspent = u,+ xPubUnspentPath = xPubBalPath x+ }+ us = mapMaybe f uns+ i a u = h u <$> g a+ return $ mapMaybe (uncurry i) us -getXPubBalances ::- (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m)- => XPubSpec -> CacheX m [XPubBal]+getXPubBalances :: (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m)+ => XPubSpec -> CacheX m [XPubBal] getXPubBalances xpub = isXPubCached xpub >>= \case True -> do incrementCounter cacheHits@@ -688,76 +696,57 @@ void pruneDB lenNotNull :: [XPubBal] -> Int-lenNotNull bals = length $ filter (not . nullBalance . xPubBal) bals+lenNotNull = length . filter (not . nullBalance . xPubBal) newXPubC :: (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) => XPubSpec -> [XPubBal] -> CacheX m ()-newXPubC xpub bals = should_index >>= \i ->+newXPubC xpub xbals = should_index >>= \i -> if i then do- a <- async $ do- incrementCounter cacheMisses- withMetrics cacheIndexTime index- wait a+ incrementCounter cacheMisses+ withMetrics cacheIndexTime index else incrementCounter cacheIgnore where op XPubUnspent {xPubUnspent = u} = (unspentPoint u, unspentBlock u)- should_index = asks cacheMin >>= \x ->- if x <= lenNotNull bals- then is_indexing >>= \y -> if y then return False else inSync- else return False- index = bracket set_index unset_index $ \(x, y) -> when (x && y) $ do+ should_index =+ asks cacheMin >>= \x ->+ if x <= lenNotNull xbals then inSync else return False+ index =+ bracket set_index unset_index $ \y -> when y $+ withMetrics cacheIndexTime $ do xpubtxt <- xpubText xpub $(logDebugS) "Cache" $- "Caching " <> xpubtxt <> ": " <> cs (show (length bals)) <>- " addresses / " <> cs (show (lenNotNull bals)) <>- " used"- utxo <- lift $ xPubUnspents xpub def+ "Caching " <> xpubtxt <> ": " <>+ cs (show (length xbals)) <> " addresses / " <>+ cs (show (lenNotNull xbals)) <> " used"+ utxo <- lift $ xPubUnspents xpub xbals def $(logDebugS) "Cache" $ "Caching " <> xpubtxt <> ": " <> cs (show (length utxo)) <> " utxos"- xtxs <- lift $ xPubTxs xpub def+ xtxs <- lift $ xPubTxs xpub xbals def $(logDebugS) "Cache" $ "Caching " <> xpubtxt <> ": " <> cs (show (length xtxs)) <> " txs" now <- systemSeconds <$> liftIO getSystemTime runRedis $ do b <- redisTouchKeys now [xpub]- c <- redisAddXPubBalances xpub bals+ c <- redisAddXPubBalances xpub xbals d <- redisAddXPubUnspents xpub (map op utxo) e <- redisAddXPubTxs xpub xtxs return $ b >> c >> d >> e >> return () $(logDebugS) "Cache" $ "Cached " <> xpubtxt- is_indexing = runRedis (Redis.exists key) key = idxPfx <> encode xpub- get_thread = do- v <- asks cacheThreads- atomically $ do- x <- readTVar v- if x <= 0- then return False- else modifyTVar v (subtract 1) >> return True- put_thread = do- v <- asks cacheThreads- atomically $ modifyTVar v (+1)- unset_index (x, y) = do- when x put_thread- when y . void . runRedis $ Redis.del [key]+ opts = Redis.SetOpts+ { Redis.setSeconds = Just 600+ , Redis.setMilliseconds = Nothing+ , Redis.setCondition = Just Redis.Nx+ }+ red = Redis.setOpts key "1" opts+ unset_index y = when y . void . runRedis $ Redis.del [key] set_index =- let opts = Redis.SetOpts- { Redis.setSeconds = Just 600- , Redis.setMilliseconds = Nothing- , Redis.setCondition = Just Redis.Nx- }- red = Redis.setOpts key "1" opts- in get_thread >>= \case- True -> do- conn <- asks cacheConn- liftIO (Redis.runRedis conn red) >>= \case- Right _ -> return (True, True)- Left _ -> return (True, False)- False -> return (False, False)+ asks cacheConn >>= \conn ->+ liftIO (Redis.runRedis conn red) >>= return . isRight inSync :: (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) => CacheX m Bool@@ -1220,27 +1209,32 @@ => XPubSpec -> [(OutPoint, BlockRef)] -> m (f Integer)-redisAddXPubUnspents _ [] = return (pure 0)+redisAddXPubUnspents _ [] =+ return (pure 0) redisAddXPubUnspents xpub utxo = zadd (utxoPfx <> encode xpub) $ map (\(p, r) -> (blockRefScore r, encode p)) utxo redisRemXPubUnspents :: (Applicative f, RedisCtx m f) => XPubSpec -> [OutPoint] -> m (f Integer)-redisRemXPubUnspents _ [] = return (pure 0)-redisRemXPubUnspents xpub ops = zrem (utxoPfx <> encode xpub) (map encode ops)+redisRemXPubUnspents _ [] =+ return (pure 0)+redisRemXPubUnspents xpub ops =+ zrem (utxoPfx <> encode xpub) (map encode ops) redisAddXPubBalances :: (Monad f, RedisCtx m f) => XPubSpec -> [XPubBal] -> m (f ()) redisAddXPubBalances _ [] = return (pure ()) redisAddXPubBalances xpub bals = do xs <- mapM (uncurry (Redis.hset (balancesPfx <> encode xpub))) entries- ys <-- forM bals $ \b ->- redisSetAddrInfo- (balanceAddress (xPubBal b))- AddressXPub- {addressXPubSpec = xpub, addressXPubPath = xPubBalPath b}+ ys <- forM bals $ \b ->+ redisSetAddrInfo+ (balanceAddress (xPubBal b))+ AddressXPub+ {+ addressXPubSpec = xpub,+ addressXPubPath = xPubBalPath b+ } return $ sequence_ xs >> sequence_ ys where entries = map (\b -> (encode (xPubBalPath b), encode (xPubBal b))) bals
src/Haskoin/Store/Common.hs view
@@ -18,8 +18,6 @@ , getActiveTxData , getDefaultBalance , getSpenders- , xPubBalsTxs- , xPubBalsUnspents , getTransaction , getNumTransaction , blockAtOrBefore@@ -27,12 +25,18 @@ , deOffset , applyLimits , applyLimitsC+ , applyLimit+ , applyLimitC , sortTxs , nub' , microseconds+ , streamThings+ , joinDescStreams ) where -import Conduit (ConduitT, dropC, mapC, takeC)+import Conduit (ConduitT, await, dropC, mapC,+ runConduit, sealConduitT, sinkList,+ takeC, yield, ($$++), (.|)) import Control.DeepSeq (NFData) import Control.Exception (Exception) import Control.Monad (forM)@@ -46,8 +50,11 @@ import Data.Hashable (Hashable) import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as I-import Data.List (sortBy)-import Data.Maybe (catMaybes)+import Data.List (sortOn)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Maybe (catMaybes, mapMaybe)+import Data.Ord (Down(..)) import Data.Serialize (Serialize (..)) import Data.Time.Clock.System (getSystemTime, systemNanoseconds, systemSeconds)@@ -111,19 +118,25 @@ getMempool :: m [(UnixTime, TxHash)] class StoreReadBase m => StoreReadExtra m where+ getAddressesTxs :: [Address] -> Limits -> m [TxRef]+ getAddressesUnspents :: [Address] -> Limits -> m [Unspent]+ getInitialGap :: m Word32+ getMaxGap :: m Word32+ getNumTxData :: Word64 -> m [TxData]+ getBalances :: [Address] -> m [Balance] getBalances as = zipWith f as <$> mapM getBalance as where f a Nothing = zeroBalance a f _ (Just b) = b- getAddressesTxs :: [Address] -> Limits -> m [TxRef]+ getAddressTxs :: Address -> Limits -> m [TxRef] getAddressTxs a = getAddressesTxs [a]+ getAddressUnspents :: Address -> Limits -> m [Unspent] getAddressUnspents a = getAddressesUnspents [a]- getAddressesUnspents :: [Address] -> Limits -> m [Unspent]- getNumTxData :: Word64 -> m [TxData]+ xPubBals :: XPubSpec -> m [XPubBal] xPubBals xpub = do igap <- getInitialGap@@ -149,50 +162,48 @@ if all nullBalance bs then return xbs else (xbs <>) <$> derive_until_gap gap m as2- xPubSummary :: XPubSpec -> m XPubSummary- xPubSummary xpub = do- bs <- filter (not . nullBalance . xPubBal) <$> xPubBals xpub- let ex = foldl max 0 [i | XPubBal {xPubBalPath = [0, i]} <- bs]- ch = foldl max 0 [i | XPubBal {xPubBalPath = [1, i]} <- bs]- uc =- sum- [ c- | XPubBal {xPubBal = Balance {balanceUnspentCount = c}} <-- bs- ]- xt = [b | b@XPubBal {xPubBalPath = [0, _]} <- bs]- rx =- sum- [ r- | XPubBal {xPubBal = Balance {balanceTotalReceived = r}} <-- xt- ]- return- XPubSummary- { xPubSummaryConfirmed = sum (map (balanceAmount . xPubBal) bs)- , xPubSummaryZero = sum (map (balanceZero . xPubBal) bs)- , xPubSummaryReceived = rx- , xPubUnspentCount = uc- , xPubChangeIndex = ch- , xPubExternalIndex = ex- }- xPubUnspents :: XPubSpec -> Limits -> m [XPubUnspent]- xPubUnspents xpub limits = do- xs <- filter positive <$> xPubBals xpub- sortBy (compare `on` unsblock) . applyLimits limits <$> xUns limits xs++ xPubSummary :: XPubSpec -> [XPubBal] -> m XPubSummary+ xPubSummary _xspec xbals = return+ XPubSummary+ { xPubSummaryConfirmed = sum (map (balanceAmount . xPubBal) bs)+ , xPubSummaryZero = sum (map (balanceZero . xPubBal) bs)+ , xPubSummaryReceived = rx+ , xPubUnspentCount = uc+ , xPubChangeIndex = ch+ , xPubExternalIndex = ex+ } where- unsblock = unspentBlock . xPubUnspent- positive XPubBal {xPubBal = Balance {balanceUnspentCount = c}} = c > 0- xPubTxs :: XPubSpec -> Limits -> m [TxRef]- xPubTxs xpub limits = do- bs <- xPubBals xpub- let as = map (balanceAddress . xPubBal) bs- getAddressesTxs as limits- xPubTxCount :: XPubSpec -> m Word32- xPubTxCount xpub = fromIntegral . length <$> xPubTxs xpub def- getMaxGap :: m Word32- getInitialGap :: m Word32+ bs = filter (not . nullBalance . xPubBal) xbals+ ex = foldl max 0 [i | XPubBal {xPubBalPath = [0, i]} <- bs]+ ch = foldl max 0 [i | XPubBal {xPubBalPath = [1, i]} <- bs]+ uc = sum [balanceUnspentCount (xPubBal b) | b <- bs]+ xt = [b | b@XPubBal {xPubBalPath = [0, _]} <- bs]+ rx = sum [balanceTotalReceived (xPubBal b) | b <- xt] + xPubUnspents :: XPubSpec -> [XPubBal] -> Limits -> m [XPubUnspent]+ xPubUnspents _xspec xbals limits =+ applyLimits limits . sortOn Down . concat <$> mapM h cs+ where+ l = deOffset limits+ g = balanceAddress . xPubBal+ cs = filter ((> 0) . balanceUnspentCount . xPubBal) xbals+ i b = getAddressUnspents (balanceAddress (xPubBal b)) l+ f b t = XPubUnspent {xPubUnspentPath = xPubBalPath b, xPubUnspent = t}+ h b = map (f b) <$> i b++ xPubTxs :: XPubSpec -> [XPubBal] -> Limits -> m [TxRef]+ xPubTxs _xspec xbals limits =+ let as = map balanceAddress $+ filter (not . nullBalance) $+ map xPubBal $+ xbals+ in getAddressesTxs as limits++ xPubTxCount :: XPubSpec -> [XPubBal] -> m Word32+ xPubTxCount xspec xbals =+ fromIntegral . length <$> xPubTxs xspec xbals def+ class StoreWrite m where setBest :: BlockHash -> m () insertBlock :: BlockData -> m ()@@ -234,14 +245,6 @@ Nothing -> return $ zeroBalance a Just b -> return b -xUns :: StoreReadExtra f => Limits -> [XPubBal] -> f [XPubUnspent]-xUns limits bs = concat <$> mapM g bs- where- f p t = XPubUnspent {xPubUnspentPath = p, xPubUnspent = t}- g b =- map (f (xPubBalPath b)) <$>- getAddressUnspents (balanceAddress (xPubBal b)) (deOffset limits)- deriveAddresses :: DeriveAddr -> XPubKey -> Word32 -> [(Word32, Address)] deriveAddresses derive xpub start = map (\i -> (i, derive xpub i)) [start ..] @@ -250,28 +253,6 @@ deriveFunction DeriveP2SH i = fst . deriveCompatWitnessAddr i deriveFunction DeriveP2WPKH i = fst . deriveWitnessAddr i -xPubBalsUnspents ::- StoreReadExtra m- => [XPubBal]- -> Limits- -> m [XPubUnspent]-xPubBalsUnspents bals limits = do- let xs = filter positive bals- applyLimits limits <$> xUns limits xs- where- positive XPubBal {xPubBal = Balance {balanceUnspentCount = c}} = c > 0--xPubBalsTxs ::- StoreReadExtra m- => [XPubBal]- -> Limits- -> m [TxRef]-xPubBalsTxs bals limits = do- let as = map balanceAddress . filter (not . nullBalance) $ map xPubBal bals- ts <- concat <$> mapM (\a -> getAddressTxs a (deOffset limits)) as- let ts' = sortBy (flip compare `on` txRefBlock) (nub' ts)- return $ applyLimits limits ts'- getTransaction :: (Monad m, StoreReadBase m) => TxHash -> m (Maybe Transaction) getTransaction h = runMaybeT $ do@@ -359,7 +340,9 @@ applyLimit l = take (fromIntegral l) deOffset :: Limits -> Limits-deOffset l = l { limit = limit l + offset l, offset = 0}+deOffset l = case limit l of+ 0 -> l{offset = 0}+ _ -> l{limit = limit l + offset l, offset = 0} applyLimitsC :: Monad m => Limits -> ConduitT i i m () applyLimitsC Limits {..} = applyOffsetC offset >> applyLimitC limit@@ -392,3 +375,47 @@ let f t = toInteger (systemSeconds t) * 1000000 + toInteger (systemNanoseconds t) `div` 1000 in liftIO $ f <$> getSystemTime++streamThings :: Monad m+ => (Limits -> m [a])+ -> Maybe (a -> TxHash)+ -> Limits+ -> ConduitT () a m ()+streamThings getit gettx limits =+ lift (getit limits) >>= \case+ [] -> return ()+ ls -> mapM yield ls >> go limits (last ls)+ where+ h l x = case gettx of+ Just g -> Just l{offset = 1, start = Just (AtTx (g x))}+ Nothing -> case limit l of+ 0 -> Nothing+ _ -> Just l{offset = offset l + limit l}+ go l x = case h l x of+ Nothing -> return ()+ Just l' -> lift (getit l') >>= \case+ [] -> return ()+ ls -> mapM yield ls >> go l' (last ls)++joinDescStreams :: (Monad m, Ord a)+ => [ConduitT () a m ()]+ -> ConduitT () a m ()+joinDescStreams xs = do+ let ss = map sealConduitT xs+ go Nothing =<< g ss+ where+ j (x, y) = (, [x]) <$> y+ g ss = let l = mapMaybe j <$> lift (traverse ($$++ await) ss)+ in Map.fromListWith (++) <$> l+ go m mp = case Map.lookupMax mp of+ Nothing -> return ()+ Just (x, ss) -> do+ case m of+ Nothing -> yield x+ Just x'+ | x == x' -> return ()+ | otherwise -> yield x+ mp1 <- g ss+ let mp2 = Map.deleteMax mp+ mp' = Map.unionWith (++) mp1 mp2+ go (Just x) mp'
src/Haskoin/Store/Database/Reader.hs view
@@ -24,8 +24,9 @@ import qualified Data.ByteString as BS import Data.Default (def) import Data.Function (on)-import Data.List (sortBy)+import Data.List (sortOn) import Data.Maybe (fromMaybe)+import Data.Ord (Down(..)) import Data.Serialize (encode) import Data.Word (Word32, Word64) import Database.RocksDB (ColumnFamily, Config (..),@@ -40,7 +41,6 @@ import Haskoin.Store.Common import Haskoin.Store.Data import Haskoin.Store.Database.Types-import Haskoin.Store.Logic (joinDescStreams) import UnliftIO (MonadIO, MonadUnliftIO, liftIO) type DatabaseReaderT = ReaderT DatabaseReader@@ -169,21 +169,17 @@ getMempoolDB DatabaseReader{databaseHandle = db} = fromMaybe [] <$> retrieve db MemKey -getAddressesTxsDB ::- MonadIO m- => [Address]- -> Limits- -> DatabaseReader- -> m [TxRef]+getAddressesTxsDB :: MonadIO m+ => [Address] -> Limits -> DatabaseReader -> m [TxRef] getAddressesTxsDB addrs limits bdb@DatabaseReader{databaseHandle = db} =- liftIO $ iters addrs [] $ \cs ->- runConduit $- joinDescStreams cs .| applyLimitsC limits .| sinkList+ applyLimits limits . sortOn Down . concat <$> mapM f addrs where- iters [] acc f = f acc- iters (a : as) acc f =- withIterCF db (addrTxCF db) $ \it ->- iters as (addressConduit a bdb (start limits) it : acc) f+ l = deOffset limits+ f a = liftIO . withIterCF db (addrTxCF db) $ \it ->+ runConduit $+ addressConduit a bdb (start l) it .|+ applyLimitC (limit l) .|+ sinkList addressConduit :: MonadUnliftIO m => Address@@ -241,14 +237,14 @@ -> DatabaseReader -> m [Unspent] getAddressesUnspentsDB addrs limits bdb@DatabaseReader{databaseHandle = db} =- liftIO $ iters addrs [] $ \cs ->- runConduit $- joinDescStreams cs .| applyLimitsC limits .| sinkList+ applyLimits limits . sortOn Down . concat <$> mapM f addrs where- iters [] acc f = f acc- iters (a : as) acc f =- withIterCF db (addrOutCF db) $ \it ->- iters as (unspentConduit a bdb (start limits) it : acc) f+ l = deOffset limits+ f a = liftIO . withIterCF db (addrTxCF db) $ \it ->+ runConduit $+ unspentConduit a bdb (start l) it .|+ applyLimitC (limit l) .|+ sinkList unspentConduit :: MonadUnliftIO m => Address
src/Haskoin/Store/Logic.hs view
@@ -13,8 +13,6 @@ , importBlock , newMempoolTx , deleteUnconfirmedTx- , streamThings- , joinDescStreams ) where import Conduit (ConduitT, await, lift, sealConduitT,@@ -673,45 +671,3 @@ 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 1 (Just (AtTx (g x))))) >>= \case- [] -> return ()- ls -> do- mapM yield ls- go (last ls)--joinDescStreams :: (Monad m, Ord a)- => [ConduitT () a m ()]- -> ConduitT () a m ()-joinDescStreams xs = do- let ss = map sealConduitT xs- go Nothing =<< g ss- where- j (x, y) = (, [x]) <$> y- g ss = let l = mapMaybe j <$> lift (traverse ($$++ await) ss)- in Map.fromListWith (++) <$> l- go m mp = case Map.lookupMax mp of- Nothing -> return ()- Just (x, ss) -> do- case m of- Nothing -> yield x- Just x'- | x == x' -> return ()- | otherwise -> yield x- mp1 <- g ss- let mp2 = Map.deleteMax mp- mp' = Map.unionWith (++) mp1 mp2- go (Just x) mp'
src/Haskoin/Store/Manager.hs view
@@ -36,8 +36,7 @@ blockStoreTxSTM, withBlockStore) import Haskoin.Store.Cache (CacheConfig (..), CacheWriter, cacheNewBlock, cacheWriter,- connectRedis, newCacheMetrics,- newCacheThreads)+ connectRedis, newCacheMetrics) import Haskoin.Store.Common (StoreEvent (..)) import Haskoin.Store.Database.Reader (DatabaseReader (..), DatabaseReaderT,@@ -103,8 +102,6 @@ -- ^ delay in microseconds to retry getting cache lock , storeConfStats :: !(Maybe Metrics.Store) -- ^ stats store- , storeConfCacheThreads :: !Int- -- ^ how many caching threads } withStore :: (MonadLoggerIO m, MonadUnliftIO m)@@ -190,15 +187,14 @@ mapM newCacheMetrics (storeConfStats cfg) >>= \metrics -> connectRedis redisurl >>= \conn -> withSubscription pub $ \evts ->- newCacheThreads (storeConfCacheThreads cfg) >>= \cth ->- let conf = c conn metrics cth+ let conf = c conn metrics in withProcess (f conf) $ \p -> cacheWriterProcesses crefresh evts (getProcessMailbox p) $ do action (Just conf) where crefresh = storeConfCacheRefresh cfg f conf cwinbox = runReaderT (cacheWriter conf cwinbox) db- c conn metrics cth =+ c conn metrics = CacheConfig { cacheConn = conn , cacheMin = storeConfCacheMin cfg@@ -207,7 +203,6 @@ , cacheRefresh = storeConfCacheRefresh cfg , cacheRetryDelay = storeConfCacheRetryDelay cfg , cacheMetrics = metrics- , cacheThreads = cth } cacheWriterProcesses :: MonadUnliftIO m
src/Haskoin/Store/Web.hs view
@@ -64,7 +64,7 @@ import Data.HashSet (HashSet) import qualified Data.HashSet as HashSet import Data.Int (Int64)-import Data.List (nub, sortBy)+import Data.List (nub) import qualified Data.Map.Strict as Map import Data.Maybe (catMaybes, fromJust, fromMaybe, isJust,@@ -186,7 +186,6 @@ , webVersion :: !String , webNoMempool :: !Bool , webStats :: !(Maybe Metrics.Store)- , webRequests :: !Int , webPriceGet :: !Int } @@ -194,38 +193,36 @@ { webConfig :: !WebConfig , webTicker :: !(TVar (HashMap Text BinfoTicker)) , webMetrics :: !(Maybe WebMetrics)- , webTokens :: !(TVar Int) } data WebMetrics = WebMetrics- { everyStat :: !StatDist- , blockStat :: !StatDist- , rawBlockStat :: !StatDist- , txStat :: !StatDist- , txsBlockStat :: !StatDist- , txAfterStat :: !StatDist- , postTxStat :: !StatDist- , mempoolStat :: !StatDist- , addrTxStat :: !StatDist- , addrTxFullStat :: !StatDist- , addrBalanceStat :: !StatDist- , addrUnspentStat :: !StatDist- , xPubStat :: !StatDist- , xPubTxStat :: !StatDist- , xPubTxFullStat :: !StatDist- , xPubUnspentStat :: !StatDist- , multiaddrStat :: !StatDist- , rawaddrStat :: !StatDist- , balanceStat :: !StatDist- , unspentStat :: !StatDist- , rawtxStat :: !StatDist- , peerStat :: !StatDist- , healthStat :: !StatDist- , dbStatsStat :: !StatDist- , eventsConnected :: !Metrics.Gauge- , inFlightRequests :: !Metrics.Gauge- , statKey :: !(V.Key (TVar (Maybe (WebMetrics -> StatDist))))- , itemsKey :: !(V.Key (TVar Int))+ { everyStat :: !StatDist+ , blockStat :: !StatDist+ , rawBlockStat :: !StatDist+ , txStat :: !StatDist+ , txsBlockStat :: !StatDist+ , txAfterStat :: !StatDist+ , postTxStat :: !StatDist+ , mempoolStat :: !StatDist+ , addrTxStat :: !StatDist+ , addrTxFullStat :: !StatDist+ , addrBalanceStat :: !StatDist+ , addrUnspentStat :: !StatDist+ , xPubStat :: !StatDist+ , xPubTxStat :: !StatDist+ , xPubTxFullStat :: !StatDist+ , xPubUnspentStat :: !StatDist+ , multiaddrStat :: !StatDist+ , rawaddrStat :: !StatDist+ , balanceStat :: !StatDist+ , unspentStat :: !StatDist+ , rawtxStat :: !StatDist+ , peerStat :: !StatDist+ , healthStat :: !StatDist+ , dbStatsStat :: !StatDist+ , eventsConnected :: !Metrics.Gauge+ , statKey :: !(V.Key (TVar (Maybe (WebMetrics -> StatDist))))+ , itemsKey :: !(V.Key (TVar Int)) } createMetrics :: MonadIO m => Metrics.Store -> m WebMetrics@@ -255,7 +252,6 @@ healthStat <- d "health" dbStatsStat <- d "dbstats" eventsConnected <- g "events.connected"- inFlightRequests <- g "inflight" statKey <- V.newKey itemsKey <- V.newKey return WebMetrics{..}@@ -281,23 +277,6 @@ start m = liftIO $ Metrics.Gauge.inc (gf m) end m = liftIO $ Metrics.Gauge.dec (gf m) -withToken :: Int -> TVar Int -> Maybe WebMetrics -> IO a -> IO a-withToken max_req tok metrics go = do- let minf = inFlightRequests <$> metrics- bracket (t tok) (p tok) $ \rem -> do- let i = fromIntegral $ max_req - rem- case minf of- Nothing -> return ()- Just inf -> Metrics.Gauge.set inf i- go- where- t tok = atomically $ do- ts <- readTVar tok- check (0 < ts)- modifyTVar tok (subtract 1)- readTVar tok- p tok _ = atomically $ modifyTVar tok (+1)- setMetrics :: MonadUnliftIO m => (WebMetrics -> StatDist) -> Int@@ -346,10 +325,10 @@ getAddressesTxs as = runInWebReader . getAddressesTxs as getAddressesUnspents as = runInWebReader . getAddressesUnspents as xPubBals = runInWebReader . xPubBals- xPubSummary = runInWebReader . xPubSummary- xPubUnspents xpub = runInWebReader . xPubUnspents xpub- xPubTxs xpub = runInWebReader . xPubTxs xpub- xPubTxCount = runInWebReader . xPubTxCount+ xPubSummary xpub = runInWebReader . xPubSummary xpub+ xPubUnspents xpub xbals = runInWebReader . xPubUnspents xpub xbals+ xPubTxs xpub xbals = runInWebReader . xPubTxs xpub xbals+ xPubTxCount xpub = runInWebReader . xPubTxCount xpub getNumTxData = runInWebReader . getNumTxData instance (MonadUnliftIO m, MonadLoggerIO m) => StoreReadBase (WebT m) where@@ -368,10 +347,10 @@ getAddressesTxs as = lift . getAddressesTxs as getAddressesUnspents as = lift . getAddressesUnspents as xPubBals = lift . xPubBals- xPubSummary = lift . xPubSummary- xPubUnspents xpub = lift . xPubUnspents xpub- xPubTxs xpub = lift . xPubTxs xpub- xPubTxCount = lift . xPubTxCount+ xPubSummary xpub = lift . xPubSummary xpub+ xPubUnspents xpub xbals = lift . xPubUnspents xpub xbals+ xPubTxs xpub xbals = lift . xPubTxs xpub xbals+ xPubTxCount xpub = lift . xPubTxCount xpub getMaxGap = lift getMaxGap getInitialGap = lift getInitialGap getNumTxData = lift . getNumTxData@@ -386,17 +365,13 @@ , webStore = store , webStats = stats , webPriceGet = pget- , webRequests = max_req } = do ticker <- newTVarIO HashMap.empty metrics <- mapM createMetrics stats- tok <- newTVarIO max_req let st = WebState- {- webConfig = cfg,- webTicker = ticker,- webMetrics = metrics,- webTokens = tok+ { webConfig = cfg+ , webTicker = ticker+ , webMetrics = metrics } net = storeNetwork store withAsync (price net pget ticker) $ \_ -> do@@ -405,7 +380,6 @@ S.scottyOptsT opts (runner . (`runReaderT` st)) $ do S.middleware reqLogger S.middleware reqSizeLimit- S.middleware $ reqToken max_req tok metrics S.defaultHandler defHandler handlePaths S.notFound $ S.raise ThingNotFound@@ -1196,13 +1170,17 @@ (MonadUnliftIO m, MonadLoggerIO m) => GetXPub -> WebT m XPubSummary scottyXPub (GetXPub xpub deriv (NoCache noCache)) = do setMetrics xPubStat 1- lift . runNoCache noCache $ xPubSummary $ XPubSpec xpub deriv+ let xspec = XPubSpec xpub deriv+ xbals <- xPubBals xspec+ lift . runNoCache noCache $ xPubSummary xspec xbals getXPubTxs :: (MonadUnliftIO m, MonadLoggerIO m) => XPubKey -> DeriveType -> LimitsParam -> Bool -> WebT m [TxRef] getXPubTxs xpub deriv plimits nocache = do limits <- paramToLimits False plimits- lift . runNoCache nocache $ xPubTxs (XPubSpec xpub deriv) limits+ let xspec = XPubSpec xpub deriv+ xbals <- xPubBals xspec+ lift . runNoCache nocache $ xPubTxs xspec xbals limits scottyXPubTxs :: (MonadUnliftIO m, MonadLoggerIO m) => GetXPubTxs -> WebT m [TxRef]@@ -1236,7 +1214,9 @@ scottyXPubUnspent (GetXPubUnspent xpub deriv pLimits (NoCache noCache)) = do setMetrics xPubUnspentStat 1 limits <- paramToLimits False pLimits- lift . runNoCache noCache $ xPubUnspents (XPubSpec xpub deriv) limits+ let xspec = XPubSpec xpub deriv+ xbals <- xPubBals xspec+ lift . runNoCache noCache $ xPubUnspents xspec xbals limits --------------------------------------- -- Blockchain.info API Compatibility --@@ -1330,9 +1310,8 @@ getBinfoActive unspentStat >>= \(xspecs, addrs) -> getNumTxId >>= \numtxid -> get_limit >>= \limit ->- get_min_conf >>= \min_conf ->+ get_min_conf >>= \min_conf -> do let len = HashSet.size addrs + HashMap.size xspecs- in do setMetrics unspentStat len net <- lift $ asks (storeNetwork . webStore . webConfig) height <- getChainHeight@@ -1353,8 +1332,9 @@ -> HashSet XPubSpec -> HashSet Address -> ConduitT () BinfoUnspent m ()-getBinfoUnspents numtxid height xspecs addrs =- joinDescStreams conduits .| mapC (uncurry binfo)+getBinfoUnspents numtxid height xspecs addrs = do+ cs <- conduits+ joinDescStreams cs .| mapC (uncurry binfo) where binfo Unspent{..} xp = let conf = case unspentBlock of@@ -1375,21 +1355,28 @@ , getBinfoUnspentXPub = xp } point_hash = outPointHash . unspentPoint- conduits = xconduits <> acounduits- xconduits =- let f x (XPubUnspent p u) =+ conduits = (<>) <$> xconduits <*> pure acounduits+ xconduits = lift $ do+ let f x (XPubUnspent u p) = let path = toSoft (listToPath p) xp = BinfoXPubPath (xPubSpecKey x) <$> path in (u, xp)- g x =- streamThings (xPubUnspents x) (point_hash . xPubUnspent) def .|- mapC (f x)- in map g (HashSet.toList xspecs)+ g x = do+ bs <- xPubBals x+ return $+ streamThings+ (xPubUnspents x bs)+ Nothing+ def{limit = 250} .|+ mapC (f x)+ mapM g (HashSet.toList xspecs) acounduits = let f u = (u, Nothing)- g a =- streamThings (getAddressUnspents a) point_hash def .|- mapC f+ g a = streamThings+ (getAddressUnspents a)+ Nothing+ def{limit = 250} .|+ mapC f in map g (HashSet.toList addrs) getBinfoTxs :: (StoreReadExtra m, MonadIO m)@@ -1402,14 +1389,17 @@ -> Bool -- prune outputs -> Int64 -- starting balance -> ConduitT () BinfoTx m ()-getBinfoTxs abook sxspecs saddrs baddrs bfilter numtxid prune bal =- joinDescStreams conduits .| go bal+getBinfoTxs abook sxspecs saddrs baddrs bfilter numtxid prune bal = do+ cs <- conduits+ joinDescStreams cs .| 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+ conduits = (<>) <$> mapM xpub_c sxspecs_ls <*> pure (map addr_c saddrs_ls)+ xpub_c x = lift $ do+ bs <- xPubBals x+ return $ streamThings (xPubTxs x bs) (Just txRefHash) def{limit = 50}+ addr_c a = streamThings (getAddressTxs a) (Just txRefHash) def{limit = 50} binfo_tx b = toBinfoTx numtxid abook prune b compute_bal_change BinfoTx{..} = let ins = mapMaybe getBinfoTxInputPrevOut getBinfoTxInputs@@ -1466,7 +1456,7 @@ in do setMetrics multiaddrStat len xbals <- get_xbals xspecs- xtxns <- mapM (fmap fromIntegral . xPubTxCount) xspecs+ xtxns <- get_xpub_tx_count xbals xspecs let sxbals = subset sxpubs xbals xabals = compute_xabals xbals addrs = addrs' `HashSet.difference` HashMap.keysSet xabals@@ -1529,6 +1519,14 @@ , getBinfoMultiAddrCashAddr = cashaddr } where+ get_xpub_tx_count xbals =+ let f (k, s) =+ case HashMap.lookup k xbals of+ Nothing -> return (k, 0)+ Just bs -> do+ n <- xPubTxCount s bs+ return (k, fromIntegral n)+ in fmap HashMap.fromList . mapM f . HashMap.toList get_filter = S.param "filter" `S.rescue` const (return BinfoFilterAll) get_best_block = getBestBlock >>= \case@@ -1705,7 +1703,7 @@ is_ext _ = False get_xspec_balance net xpub = do xbals <- xPubBals xpub- xts <- xPubTxCount xpub+ xts <- xPubTxCount xpub xbals let val = sum $ map balanceAmount $ map xPubBal xbals zro = sum $ map balanceZero $ map xPubBal xbals exs = filter is_ext xbals@@ -2079,34 +2077,24 @@ runner <- askRunInIO return $ \app req respond -> do var <- newTVarIO B.empty- req' <- case metrics of- Nothing ->- return- req- {- requestBody =- req_body var (getRequestBodyChunk req)- }- Just m -> do- stat_var <- newTVarIO Nothing- item_var <- newTVarIO 0- let vault' = V.insert (statKey m) stat_var $- V.insert (itemsKey m) item_var $- vault req- return- req- {- vault = vault',- requestBody =- req_body var (getRequestBodyChunk req)- }+ req' <-+ let rb = req_body var (getRequestBodyChunk req)+ rq = req{requestBody = rb}+ in case metrics of+ Nothing -> return rq+ Just m -> do+ stat_var <- newTVarIO Nothing+ item_var <- newTVarIO 0+ let vt = V.insert (statKey m) stat_var $+ V.insert (itemsKey m) item_var $+ vault rq+ return rq{vault = vt} bracket start (end var runner req') $ \t1 -> app req' $ \res -> do t2 <- systemToUTCTime <$> getSystemTime- let diff = round $ diffUTCTime t2 t1 * 1000 b <- readTVarIO var let s = responseStatus res- msg = fmtReq b req' <> ": " <> fmtStatus s diff+ msg = fmtReq b req' <> ": " <> fmtStatus s if statusIsSuccessful s then runner $ $(logDebugS) "Web" msg else runner $ $(logErrorS) "Web" msg@@ -2144,10 +2132,6 @@ runner $ $(logWarnS) "Web" $ "Slow [" <> cs (show diff) <> " ms]: " <> fmtReq b req -reqToken :: Int -> TVar Int -> Maybe WebMetrics -> Middleware-reqToken max_req tok metrics app req respond =- withToken max_req tok metrics $ app req respond- reqSizeLimit :: Middleware reqSizeLimit = requestSizeLimitMiddleware lim where@@ -2170,9 +2154,6 @@ Right t -> " [" <> t <> "]" in T.decodeUtf8 (m <> " " <> p <> q <> " " <> cs (show v)) <> txt -fmtStatus :: Status -> Int -> Text-fmtStatus s i =- cs (show (statusCode s)) <> " " <>- cs (statusMessage s) <> " (" <>- cs (show i) <> " ms)"+fmtStatus :: Status -> Text+fmtStatus s = cs (show (statusCode s)) <> " " <> cs (statusMessage s)
test/Haskoin/StoreSpec.hs view
@@ -99,7 +99,6 @@ , storeConfCacheRefresh = 750 , storeConfCacheRetryDelay = 100000 , storeConfStats = Nothing- , storeConfCacheThreads = 8 } withStore cfg $ \Store {..} -> withSubscription storePublisher $ \sub ->