packages feed

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 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 ->