diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,6 +4,18 @@ 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.35.8 +### Changed +- Put derivations stat inside database. + +## 0.35.7 +### Added +- Added counters for database retrievals. +- Added counter for xpub derivations. + +### Changed +- Removed some buggy or unnecessary stats. + ## 0.35.6 ### Changed - Improve web server statistics. diff --git a/haskoin-store.cabal b/haskoin-store.cabal --- a/haskoin-store.cabal +++ b/haskoin-store.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: ec49d4278d166be7a2b738a510e0aa03c4cd876a0e9be3eea69d21c4effac640 +-- hash: 585582b76ffd5ba96243c759d59ac87300d0868ed1b082361e75f3955834a402 name: haskoin-store -version: 0.53.6 +version: 0.53.8 synopsis: Storage and index for Bitcoin and Bitcoin Cash description: Please see the README on GitHub at category: Bitcoin, Finance, Network @@ -62,7 +62,7 @@ , hashable >=1.3.0.0 , haskoin-core >=0.20.4 , haskoin-node >=0.17.0 - , haskoin-store-data ==0.53.6 + , haskoin-store-data ==0.53.8 , hedis >=0.12.13 , http-types >=0.12.3 , lens >=4.18.1 @@ -116,7 +116,7 @@ , haskoin-core >=0.20.4 , haskoin-node >=0.17.0 , haskoin-store - , haskoin-store-data ==0.53.6 + , haskoin-store-data ==0.53.8 , hedis >=0.12.13 , http-types >=0.12.3 , lens >=4.18.1 @@ -175,7 +175,7 @@ , haskoin-core >=0.20.4 , haskoin-node >=0.17.0 , haskoin-store - , haskoin-store-data ==0.53.6 + , haskoin-store-data ==0.53.8 , hedis >=0.12.13 , hspec >=2.7.1 , http-types >=0.12.3 diff --git a/src/Haskoin/Store/BlockStore.hs b/src/Haskoin/Store/BlockStore.hs --- a/src/Haskoin/Store/BlockStore.hs +++ b/src/Haskoin/Store/BlockStore.hs @@ -260,7 +260,7 @@ getMempool = runRocksDB getMempool -instance MonadIO m => StoreReadExtra (BlockT m) where +instance MonadUnliftIO m => StoreReadExtra (BlockT m) where getMaxGap = runRocksDB getMaxGap getInitialGap = diff --git a/src/Haskoin/Store/Cache.hs b/src/Haskoin/Store/Cache.hs --- a/src/Haskoin/Store/Cache.hs +++ b/src/Haskoin/Store/Cache.hs @@ -167,7 +167,6 @@ t2 <- systemToUTCTime <$> liftIO getSystemTime let diff = round $ diffUTCTime t2 t1 * 1000 df metrics `addStatTime` diff - df metrics `addStatItems` 1 addStatQuery (df metrics) incrementCounter :: MonadIO m diff --git a/src/Haskoin/Store/Common.hs b/src/Haskoin/Store/Common.hs --- a/src/Haskoin/Store/Common.hs +++ b/src/Haskoin/Store/Common.hs @@ -115,6 +115,18 @@ getUnspent :: OutPoint -> m (Maybe Unspent) getMempool :: m [(UnixTime, TxHash)] + countBlocks :: Int -> m () + countBlocks _ = return () + + countTxs :: Int -> m () + countTxs _ = return () + + countBalances :: Int -> m () + countBalances _ = return () + + countUnspents :: Int -> m () + countUnspents _ = return () + class StoreReadBase m => StoreReadExtra m where getAddressesTxs :: [Address] -> Limits -> m [TxRef] getAddressesUnspents :: [Address] -> Limits -> m [Unspent] @@ -155,6 +167,7 @@ derive_until_gap _ _ [] = return [] derive_until_gap gap m as = do let (as1, as2) = splitAt (fromIntegral gap) as + countXPubDerivations (length as1) bs <- getBalances (map snd as1) let xbs = zipWith (xbalance m) bs (map fst as1) if all nullBalance bs @@ -185,7 +198,10 @@ where l = deOffset limits cs = filter ((> 0) . balanceUnspentCount . xPubBal) xbals - i b = getAddressUnspents (balanceAddress (xPubBal b)) l + i b = do + us <- getAddressUnspents (balanceAddress (xPubBal b)) l + countUnspents (length us) + return us f b t = XPubUnspent {xPubUnspentPath = xPubBalPath b, xPubUnspent = t} h b = map (f b) <$> i b @@ -199,6 +215,12 @@ xPubTxCount :: XPubSpec -> [XPubBal] -> m Word32 xPubTxCount xspec xbals = fromIntegral . length <$> xPubTxs xspec xbals def + + countTxRefs :: Int -> m () + countTxRefs _ = return () + + countXPubDerivations :: Int -> m () + countXPubDerivations _ = return () class StoreWrite m where setBest :: BlockHash -> m () diff --git a/src/Haskoin/Store/Database/Reader.hs b/src/Haskoin/Store/Database/Reader.hs --- a/src/Haskoin/Store/Database/Reader.hs +++ b/src/Haskoin/Store/Database/Reader.hs @@ -1,10 +1,14 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module Haskoin.Store.Database.Reader ( -- * RocksDB Database Access DatabaseReader (..) , DatabaseReaderT + , DatabaseStats(..) + , createDatabaseStats , withDatabaseReader , addrTxCF , addrOutCF @@ -26,7 +30,7 @@ import Data.Function (on) import Data.List (sortOn) import Data.Maybe (fromMaybe) -import Data.Ord (Down(..)) +import Data.Ord (Down (..)) import Data.Serialize (encode) import Data.Word (Word32, Word64) import Database.RocksDB (ColumnFamily, Config (..), @@ -41,18 +45,52 @@ import Haskoin.Store.Common import Haskoin.Store.Data import Haskoin.Store.Database.Types +import qualified System.Metrics as Metrics +import System.Metrics.Counter (Counter) +import qualified System.Metrics.Counter as Counter import UnliftIO (MonadIO, MonadUnliftIO, liftIO) type DatabaseReaderT = ReaderT DatabaseReader +data DatabaseStats = + DatabaseStats + { databaseBlockCount :: !Counter + , databaseTxCount :: !Counter + , databaseBalanceCount :: !Counter + , databaseUnspentCount :: !Counter + , databaseTxRefCount :: !Counter + , databaseDerivations :: !Counter + } + data DatabaseReader = DatabaseReader { databaseHandle :: !DB , databaseMaxGap :: !Word32 , databaseInitialGap :: !Word32 , databaseNetwork :: !Network + , databaseStats :: !(Maybe DatabaseStats) } +createDatabaseStats :: MonadIO m => Metrics.Store -> m DatabaseStats +createDatabaseStats s = liftIO $ do + databaseBlockCount <- Metrics.createCounter "database.blocks" s + databaseTxCount <- Metrics.createCounter "database.txs" s + databaseBalanceCount <- Metrics.createCounter "database.balances" s + databaseUnspentCount <- Metrics.createCounter "database.unspents" s + databaseTxRefCount <- Metrics.createCounter "database.txrefs" s + databaseDerivations <- Metrics.createCounter "database.derivations" s + return DatabaseStats{..} + +incrementCounter :: MonadIO m + => (DatabaseStats -> Counter) + -> Int + -> ReaderT DatabaseReader m () +incrementCounter f i = do + stats <- asks databaseStats + case stats of + Just s -> liftIO $ Counter.add (f s) (fromIntegral i) + Nothing -> return () + dataVersion :: Word32 dataVersion = 17 @@ -61,9 +99,10 @@ -> Word32 -> Word32 -> FilePath + -> Maybe DatabaseStats -> DatabaseReaderT m a -> m a -withDatabaseReader net igap gap dir f = +withDatabaseReader net igap gap dir stats f = withDBCF dir cfg columnFamilyConfig $ \db -> do let bdb = DatabaseReader @@ -71,6 +110,7 @@ , databaseMaxGap = gap , databaseNetwork = net , databaseInitialGap = igap + , databaseStats = stats } initRocksDB bdb runReaderT f bdb @@ -129,65 +169,98 @@ setInitRocksDB :: MonadIO m => DB -> m () setInitRocksDB db = insert db VersionKey dataVersion -getBestDatabaseReader :: MonadIO m => DatabaseReader -> m (Maybe BlockHash) -getBestDatabaseReader DatabaseReader{databaseHandle = db} = - retrieve db BestKey +getBestDB :: MonadIO m + => DatabaseReaderT m (Maybe BlockHash) +getBestDB = + asks databaseHandle >>= (`retrieve` BestKey) -getBlocksAtHeightDB :: MonadIO m => BlockHeight -> DatabaseReader -> m [BlockHash] -getBlocksAtHeightDB h DatabaseReader{databaseHandle = db} = +getBlocksAtHeightDB :: MonadIO m + => BlockHeight + -> DatabaseReaderT m [BlockHash] +getBlocksAtHeightDB h = do + db <- asks databaseHandle retrieveCF db (heightCF db) (HeightKey h) >>= \case Nothing -> return [] - Just ls -> return ls + Just ls -> countBlocks (length ls) >> return ls -getDatabaseReader :: MonadIO m => BlockHash -> DatabaseReader -> m (Maybe BlockData) -getDatabaseReader h DatabaseReader{databaseHandle = db} = - retrieveCF db (blockCF db) (BlockKey h) +getDatabaseReader :: MonadIO m + => BlockHash + -> DatabaseReaderT m (Maybe BlockData) +getDatabaseReader h = do + db <- asks databaseHandle + retrieveCF db (blockCF db) (BlockKey h) >>= \case + Nothing -> return Nothing + Just b -> countBlocks 1 >> return (Just b) -getTxDataDB :: MonadIO m => TxHash -> DatabaseReader -> m (Maybe TxData) -getTxDataDB th DatabaseReader{databaseHandle = db} = - retrieveCF db (txCF db) (TxKey th) +getTxDataDB :: MonadIO m + => TxHash -> DatabaseReaderT m (Maybe TxData) +getTxDataDB th = do + db <- asks databaseHandle + retrieveCF db (txCF db) (TxKey th) >>= \case + Nothing -> return Nothing + Just t -> countTxs 1 >> return (Just t) -getNumTxDataDB :: MonadIO m => Word64 -> DatabaseReader -> m [TxData] -getNumTxDataDB i r@DatabaseReader{databaseHandle = db} = do +getNumTxDataDB :: MonadIO m + => Word64 + -> DatabaseReaderT m [TxData] +getNumTxDataDB i = do + db <- asks databaseHandle let (sk, w) = decodeTxKey i ls <- liftIO $ matchingAsListCF db (txCF db) (TxKeyS sk) let f t = let bs = encode $ txHash (txData t) b = BS.head (BS.drop 6 bs) w' = b .&. 0xf8 in w == w' - return $ filter f $ map snd ls + txs = filter f $ map snd ls + countTxs (length txs) + return txs -getSpenderDB :: MonadIO m => OutPoint -> DatabaseReader -> m (Maybe Spender) -getSpenderDB op DatabaseReader{databaseHandle = db} = +getSpenderDB :: MonadIO m + => OutPoint + -> DatabaseReaderT m (Maybe Spender) +getSpenderDB op = do + db <- asks databaseHandle retrieveCF db (spenderCF db) $ SpenderKey op -getBalanceDB :: MonadIO m => Address -> DatabaseReader -> m (Maybe Balance) -getBalanceDB a DatabaseReader{databaseHandle = db} = - fmap (valToBalance a) <$> retrieveCF db (balanceCF db) (BalKey a) +getBalanceDB :: MonadIO m + => Address + -> DatabaseReaderT m (Maybe Balance) +getBalanceDB a = do + db <- asks databaseHandle + fmap (valToBalance a) <$> retrieveCF db (balanceCF db) (BalKey a) >>= \case + Nothing -> return Nothing + Just b -> countBalances 1 >> return (Just b) -getMempoolDB :: MonadIO m => DatabaseReader -> m [(UnixTime, TxHash)] -getMempoolDB DatabaseReader{databaseHandle = db} = +getMempoolDB :: MonadIO m + => DatabaseReaderT m [(UnixTime, TxHash)] +getMempoolDB = do + db <- asks databaseHandle fromMaybe [] <$> retrieve db MemKey -getAddressesTxsDB :: MonadIO m - => [Address] -> Limits -> DatabaseReader -> m [TxRef] -getAddressesTxsDB addrs limits bdb@DatabaseReader{databaseHandle = db} = - applyLimits limits . sortOn Down . concat <$> mapM f addrs +getAddressesTxsDB :: MonadUnliftIO m + => [Address] + -> Limits + -> DatabaseReaderT m [TxRef] +getAddressesTxsDB addrs limits = do + txs <- applyLimits limits . sortOn Down . concat <$> mapM f addrs + countTxRefs (length txs) + return txs where l = deOffset limits - f a = liftIO . withIterCF db (addrTxCF db) $ \it -> - runConduit $ - addressConduit a bdb (start l) it .| - applyLimitC (limit l) .| - sinkList + f a = do + db <- asks databaseHandle + withIterCF db (addrTxCF db) $ \it -> + runConduit $ + addressConduit a (start l) it .| + applyLimitC (limit l) .| + sinkList addressConduit :: MonadUnliftIO m => Address - -> DatabaseReader -> Maybe Start -> Iterator - -> ConduitT i TxRef m () -addressConduit a bdb s it = + -> ConduitT i TxRef (DatabaseReaderT m) () +addressConduit a s it = x .| mapC (uncurry f) where f (AddrTxKey _ t) () = t @@ -201,7 +274,7 @@ (AddrTxKeyA a) (AddrTxKeyB a (BlockRef bh maxBound)) Just (AtTx txh) -> - lift (getTxDataDB txh bdb) >>= \case + lift (getTxDataDB txh) >>= \case Just TxData {txDataBlock = b@BlockRef{}} -> matchingSkip it (AddrTxKeyA a) (AddrTxKeyB a b) Just TxData {txDataBlock = MemRef{}} -> @@ -213,46 +286,53 @@ (dropWhileC (cond . fst) >> mapC id) Nothing -> return () -getAddressTxsDB :: - MonadIO m - => Address - -> Limits - -> DatabaseReader - -> m [TxRef] -getAddressTxsDB a limits bdb@DatabaseReader{databaseHandle = db} = - liftIO . withIterCF db (addrTxCF db) $ \it -> - runConduit $ - addressConduit a bdb (start limits) it .| - applyLimitsC limits .| - sinkList +getAddressTxsDB :: MonadUnliftIO m + => Address + -> Limits + -> DatabaseReaderT m [TxRef] +getAddressTxsDB a limits = do + db <- asks databaseHandle + txs <- withIterCF db (addrTxCF db) $ \it -> + runConduit $ + addressConduit a (start limits) it .| + applyLimitsC limits .| + sinkList + countTxRefs (length txs) + return txs -getUnspentDB :: MonadIO m => OutPoint -> DatabaseReader -> m (Maybe Unspent) -getUnspentDB p DatabaseReader{databaseHandle = db} = - fmap (valToUnspent p) <$> retrieveCF db (unspentCF db) (UnspentKey p) +getUnspentDB :: MonadIO m + => OutPoint + -> DatabaseReaderT m (Maybe Unspent) +getUnspentDB p = do + db <- asks databaseHandle + fmap (valToUnspent p) <$> retrieveCF db (unspentCF db) (UnspentKey p) >>= \case + Nothing -> return Nothing + Just u -> countUnspents 1 >> return (Just u) -getAddressesUnspentsDB :: - MonadIO m - => [Address] - -> Limits - -> DatabaseReader - -> m [Unspent] -getAddressesUnspentsDB addrs limits bdb@DatabaseReader{databaseHandle = db} = - applyLimits limits . sortOn Down . concat <$> mapM f addrs +getAddressesUnspentsDB :: MonadUnliftIO m + => [Address] + -> Limits + -> DatabaseReaderT m [Unspent] +getAddressesUnspentsDB addrs limits = do + us <- applyLimits limits . sortOn Down . concat <$> mapM f addrs + countUnspents (length us) + return us where l = deOffset limits - f a = liftIO . withIterCF db (addrOutCF db) $ \it -> - runConduit $ - unspentConduit a bdb (start l) it .| - applyLimitC (limit l) .| - sinkList + f a = do + db <- asks databaseHandle + withIterCF db (addrOutCF db) $ \it -> + runConduit $ + unspentConduit a (start l) it .| + applyLimitC (limit l) .| + sinkList unspentConduit :: MonadUnliftIO m => Address - -> DatabaseReader -> Maybe Start -> Iterator - -> ConduitT i Unspent m () -unspentConduit a bdb s it = + -> ConduitT i Unspent (DatabaseReaderT m) () +unspentConduit a s it = x .| mapC (uncurry toUnspent) where x = case s of @@ -264,7 +344,7 @@ (AddrOutKeyA a) (AddrOutKeyB a (BlockRef h maxBound)) Just (AtTx txh) -> - lift (getTxDataDB txh bdb) >>= \case + lift (getTxDataDB txh) >>= \case Just TxData {txDataBlock = b@BlockRef{}} -> matchingSkip it (AddrOutKeyA a) (AddrOutKeyB a b) Just TxData {txDataBlock = MemRef{}} -> @@ -276,15 +356,16 @@ (dropWhileC (cond . fst) >> mapC id) Nothing -> return () -getAddressUnspentsDB :: - MonadIO m - => Address - -> Limits - -> DatabaseReader - -> m [Unspent] -getAddressUnspentsDB a limits bdb@DatabaseReader{databaseHandle = db} = - liftIO $ withIterCF db (addrOutCF db) $ \it -> runConduit $ - x it .| applyLimitsC limits .| mapC (uncurry toUnspent) .| sinkList +getAddressUnspentsDB :: MonadUnliftIO m + => Address + -> Limits + -> DatabaseReaderT m [Unspent] +getAddressUnspentsDB a limits = do + db <- asks databaseHandle + us <- withIterCF db (addrOutCF db) $ \it -> runConduit $ + x it .| applyLimitsC limits .| mapC (uncurry toUnspent) .| sinkList + countUnspents (length us) + return us where x it = case start limits of Nothing -> @@ -295,7 +376,7 @@ (AddrOutKeyA a) (AddrOutKeyB a (BlockRef h maxBound)) Just (AtTx txh) -> - lift (getTxDataDB txh bdb) >>= \case + lift (getTxDataDB txh) >>= \case Just TxData {txDataBlock = b@BlockRef{}} -> matchingSkip it (AddrOutKeyA a) (AddrOutKeyB a b) Just TxData {txDataBlock = MemRef{}} -> @@ -309,20 +390,27 @@ instance MonadIO m => StoreReadBase (DatabaseReaderT m) where getNetwork = asks databaseNetwork - getTxData t = ask >>= getTxDataDB t - getSpender p = ask >>= getSpenderDB p - getUnspent a = ask >>= getUnspentDB a - getBalance a = ask >>= getBalanceDB a - getMempool = ask >>= getMempoolDB - getBestBlock = ask >>= getBestDatabaseReader - getBlocksAtHeight h = ask >>= getBlocksAtHeightDB h - getBlock b = ask >>= getDatabaseReader b + getTxData t = getTxDataDB t + getSpender p = getSpenderDB p + getUnspent a = getUnspentDB a + getBalance a = getBalanceDB a + getMempool = getMempoolDB + getBestBlock = getBestDB + getBlocksAtHeight h = getBlocksAtHeightDB h + getBlock b = getDatabaseReader b + countBlocks = incrementCounter databaseBlockCount + countTxs = incrementCounter databaseTxCount + countBalances = incrementCounter databaseBalanceCount + countUnspents = incrementCounter databaseUnspentCount -instance MonadIO m => StoreReadExtra (DatabaseReaderT m) where - getAddressesTxs as limits = ask >>= getAddressesTxsDB as limits - getAddressesUnspents as limits = ask >>= getAddressesUnspentsDB as limits - getAddressUnspents a limits = ask >>= getAddressUnspentsDB a limits - getAddressTxs a limits = ask >>= getAddressTxsDB a limits +instance MonadUnliftIO m => StoreReadExtra (DatabaseReaderT m) where + getAddressesTxs as limits = getAddressesTxsDB as limits + getAddressesUnspents as limits = getAddressesUnspentsDB as limits + getAddressUnspents a limits = getAddressUnspentsDB a limits + getAddressTxs a limits = getAddressTxsDB a limits getMaxGap = asks databaseMaxGap getInitialGap = asks databaseInitialGap - getNumTxData t = ask >>= getNumTxDataDB t + getNumTxData t = getNumTxDataDB t + countTxRefs = incrementCounter databaseTxRefCount + countXPubDerivations = incrementCounter databaseDerivations + diff --git a/src/Haskoin/Store/Manager.hs b/src/Haskoin/Store/Manager.hs --- a/src/Haskoin/Store/Manager.hs +++ b/src/Haskoin/Store/Manager.hs @@ -40,6 +40,7 @@ import Haskoin.Store.Common (StoreEvent (..)) import Haskoin.Store.Database.Reader (DatabaseReader (..), DatabaseReaderT, + createDatabaseStats, withDatabaseReader) import NQE (Inbox, Process (..), Publisher, publishSTM, receive, @@ -125,12 +126,15 @@ } connectDB :: MonadUnliftIO m => StoreConfig -> DatabaseReaderT m a -> m a -connectDB cfg = +connectDB cfg f = do + stats <- mapM createDatabaseStats (storeConfStats cfg) withDatabaseReader (storeConfNetwork cfg) (storeConfInitialGap cfg) (storeConfGap cfg) (storeConfDB cfg) + stats + f blockStoreCfg :: StoreConfig -> Node diff --git a/src/Haskoin/Store/Stats.hs b/src/Haskoin/Store/Stats.hs --- a/src/Haskoin/Store/Stats.hs +++ b/src/Haskoin/Store/Stats.hs @@ -4,7 +4,6 @@ , withStats , createStatDist , addStatTime - , addStatItems , addClientError , addServerError , addStatQuery @@ -52,7 +51,6 @@ StatData { statTimes :: ![Int64], - statItems :: !Int64, statQueries :: !Int64, statClientErrors :: !Int64, statServerErrors :: !Int64 @@ -62,7 +60,6 @@ StatDist { distQueue :: !(TQueue Int64), - distItems :: !(TVar Int64), distQueries :: !(TVar Int64), distClientErrors :: !(TVar Int64), distServerErrors :: !(TVar Int64) @@ -71,13 +68,11 @@ createStatDist :: MonadIO m => Text -> Store -> m StatDist createStatDist t store = liftIO $ do q <- newTQueueIO - items <- newTVarIO 0 queries <- newTVarIO 0 client_errors <- newTVarIO 0 server_errors <- newTVarIO 0 let metrics = HashMap.fromList [ (t <> ".query_count", Counter . statQueries) - , (t <> ".item_count", Counter . statItems) , (t <> ".errors.client", Counter . statClientErrors) , (t <> ".errors.server", Counter . statServerErrors) , (t <> ".mean_ms", Gauge . mean . statTimes) @@ -85,11 +80,10 @@ , (t <> ".max_ms", Gauge . maxi . statTimes) , (t <> ".min_ms", Gauge . mini . statTimes) , (t <> ".p90max_ms", Gauge . p90max . statTimes) - , (t <> ".p90min_ms", Gauge . p90min . statTimes) , (t <> ".p90avg_ms", Gauge . p90avg . statTimes) , (t <> ".var_ms", Gauge . var . statTimes) ] - let sd = StatDist q items queries client_errors server_errors + let sd = StatDist q queries client_errors server_errors registerGroup metrics (flush sd) store return sd @@ -100,10 +94,6 @@ addStatTime q = liftIO . atomically . writeTQueue (distQueue q) -addStatItems :: MonadIO m => StatDist -> Int64 -> m () -addStatItems q = - liftIO . atomically . modifyTVar (distItems q) . (+) - addStatQuery :: MonadIO m => StatDist -> m () addStatQuery q = liftIO . atomically $ modifyTVar (distQueries q) (+1) @@ -117,13 +107,12 @@ liftIO . atomically $ modifyTVar (distServerErrors q) (+1) flush :: MonadIO m => StatDist -> m StatData -flush (StatDist q i n c s) = atomically $ do +flush (StatDist q n c s) = atomically $ do ts <- flushTQueue q - is <- readTVar i qs <- readTVar n ce <- readTVar c se <- readTVar s - return $ StatData ts is qs ce se + return $ StatData ts qs ce se average :: Fractional a => L.Fold a a average = (/) <$> L.sum <*> L.genericLength @@ -150,16 +139,6 @@ h:_ -> h where sorted = sortBy (comparing Down) ls - len = length sorted - chopped = drop (length sorted * 1 `div` 10) sorted - -p90min :: [Int64] -> Int64 -p90min ls = - case chopped of - [] -> 0 - h:_ -> h - where - sorted = sort ls len = length sorted chopped = drop (length sorted * 1 `div` 10) sorted diff --git a/src/Haskoin/Store/Web.hs b/src/Haskoin/Store/Web.hs --- a/src/Haskoin/Store/Web.hs +++ b/src/Haskoin/Store/Web.hs @@ -260,7 +260,6 @@ -- Request , statKey :: !(V.Key (TVar (Maybe (WebMetrics -> StatDist)))) - , itemsKey :: !(V.Key (TVar Int)) } createMetrics :: MonadIO m => Metrics.Store -> m WebMetrics @@ -338,7 +337,6 @@ statEvents <- g "events.connected" statKey <- V.newKey - itemsKey <- V.newKey return WebMetrics{..} where d x = createStatDist ("web." <> x) s @@ -362,16 +360,6 @@ start m = liftIO $ Metrics.Gauge.inc (gf m) end m = liftIO $ Metrics.Gauge.dec (gf m) -setCount :: MonadUnliftIO m => Int -> WebT m () -setCount i = - asks webMetrics >>= mapM_ go - where - go m = do - req <- S.request - let t = fromMaybe e $ V.lookup (itemsKey m) (vault req) - atomically $ writeTVar t i - e = error "do not count on me" - setMetrics :: MonadUnliftIO m => (WebMetrics -> StatDist) -> WebT m () @@ -879,7 +867,6 @@ Nothing -> raise ThingNotFound Just b -> do - setCount 1 return $ pruneTx noTx b getBlocks :: (MonadUnliftIO m, MonadLoggerIO m) @@ -894,7 +881,6 @@ scottyBlocks (GetBlocks hs (NoTx notx)) = do setMetrics statBlock bs <- getBlocks hs notx - setCount (length bs) return bs pruneTx :: Bool -> BlockData -> BlockData @@ -908,7 +894,6 @@ scottyBlockRaw (GetBlockRaw h) = do setMetrics statBlockRaw b <- getRawBlock h - setCount 1 return $ RawResult b getRawBlock :: (MonadUnliftIO m, MonadLoggerIO m) @@ -940,7 +925,6 @@ Just bb -> getBlock bb >>= \case Nothing -> raise ThingNotFound Just b -> do - setCount 1 return $ pruneTx notx b scottyBlockBestRaw :: @@ -953,7 +937,6 @@ Nothing -> raise ThingNotFound Just bb -> do b <- getRawBlock bb - setCount 1 return $ RawResult b -- GET BlockLatest -- @@ -967,7 +950,6 @@ blocks <- getBestBlock >>= maybe (raise ThingNotFound) (go [] <=< getBlock) - setCount (length blocks) return blocks where go acc Nothing = return $ reverse acc @@ -985,7 +967,6 @@ scottyBlockHeight (GetBlockHeight h (NoTx notx)) = do setMetrics statBlock blocks <- (`getBlocks` notx) =<< getBlocksAtHeight (fromIntegral h) - setCount (length blocks) return blocks scottyBlockHeights :: @@ -996,7 +977,6 @@ setMetrics statBlock bhs <- concat <$> mapM getBlocksAtHeight (fromIntegral <$> heights) blocks <- getBlocks bhs notx - setCount (length blocks) return blocks scottyBlockHeightRaw :: @@ -1006,7 +986,6 @@ scottyBlockHeightRaw (GetBlockHeightRaw h) = do setMetrics statBlockRaw blocks <- mapM getRawBlock =<< getBlocksAtHeight (fromIntegral h) - setCount (length blocks) return $ RawResultList blocks -- GET BlockTime / BlockTimeRaw -- @@ -1019,7 +998,6 @@ blockAtOrBefore ch t >>= \case Nothing -> raise ThingNotFound Just b -> do - setCount 1 return $ pruneTx notx b scottyBlockMTP :: (MonadUnliftIO m, MonadLoggerIO m) @@ -1030,7 +1008,6 @@ blockAtOrAfterMTP ch t >>= \case Nothing -> raise ThingNotFound Just b -> do - setCount 1 return $ pruneTx notx b scottyBlockTimeRaw :: (MonadUnliftIO m, MonadLoggerIO m) @@ -1042,7 +1019,6 @@ Nothing -> raise ThingNotFound Just b -> do raw <- lift $ toRawBlock b - setCount 1 return $ RawResult raw scottyBlockMTPRaw :: (MonadUnliftIO m, MonadLoggerIO m) @@ -1054,7 +1030,6 @@ Nothing -> raise ThingNotFound Just b -> do raw <- lift $ toRawBlock b - setCount 1 return $ RawResult raw -- GET Transactions -- @@ -1065,7 +1040,6 @@ getTransaction txid >>= \case Nothing -> raise ThingNotFound Just tx -> do - setCount 1 return tx scottyTxs :: @@ -1073,7 +1047,6 @@ scottyTxs (GetTxs txids) = do setMetrics statTransaction txs <- catMaybes <$> mapM f (nub txids) - setCount (length txs) return txs where f x = lift $ withRunInIO $ \run -> @@ -1087,7 +1060,6 @@ getTransaction txid >>= \case Nothing -> raise ThingNotFound Just tx -> do - setCount 1 return $ RawResult (transactionData tx) scottyTxsRaw :: @@ -1097,7 +1069,6 @@ scottyTxsRaw (GetTxsRaw txids) = do setMetrics statTransactionRaw txs <- catMaybes <$> mapM f (nub txids) - setCount (length txs) return $ RawResultList $ transactionData <$> txs where f x = lift $ withRunInIO $ \run -> @@ -1124,7 +1095,6 @@ scottyTxsBlock (GetTxsBlock h) = do setMetrics statTransactionsBlock txs <- getTxsBlock h - setCount (length txs) return txs scottyTxsBlockRaw :: @@ -1134,7 +1104,6 @@ scottyTxsBlockRaw (GetTxsBlockRaw h) = do setMetrics statTransactionsBlockRaw txs <- fmap transactionData <$> getTxsBlock h - setCount (length txs) return $ RawResultList txs -- GET TransactionAfterHeight -- @@ -1145,7 +1114,6 @@ -> WebT m (GenericResult (Maybe Bool)) scottyTxAfter (GetTxAfter txid height) = do setMetrics statTransactionAfter - setCount 1 GenericResult <$> cbAfterHeight (fromIntegral height) txid -- | Check if any of the ancestors of this transaction is a coinbase after the @@ -1188,7 +1156,7 @@ scottyPostTx (PostTx tx) = do setMetrics statTransactionPost lift (asks webConfig) >>= \cfg -> lift (publishTx cfg tx) >>= \case - Right () -> setCount 1 >> return (TxId (txHash tx)) + Right () -> return (TxId (txHash tx)) Left e@(PubReject _) -> raise $ UserError (show e) _ -> raise ServerError @@ -1248,7 +1216,6 @@ let wl' = wl { maxLimitCount = 0 } l = Limits (validateLimit wl' False limitM) (fromIntegral o) Nothing ths <- map snd . applyLimits l <$> getMempool - setCount (length ths) return ths scottyEvents :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () @@ -1284,7 +1251,6 @@ scottyAddrTxs (GetAddrTxs addr pLimits) = do setMetrics statAddressTransactions txs <- getAddressTxs addr =<< paramToLimits False pLimits - setCount (length txs) return txs scottyAddrsTxs :: @@ -1292,7 +1258,6 @@ scottyAddrsTxs (GetAddrsTxs addrs pLimits) = do setMetrics statAddressTransactions txs <- getAddressesTxs addrs =<< paramToLimits False pLimits - setCount (length txs) return txs scottyAddrTxsFull :: @@ -1303,7 +1268,6 @@ setMetrics statAddressTransactionsFull txs <- getAddressTxs addr =<< paramToLimits True pLimits ts <- catMaybes <$> mapM (getTransaction . txRefHash) txs - setCount (length ts) return ts scottyAddrsTxsFull :: (MonadUnliftIO m, MonadLoggerIO m) @@ -1312,14 +1276,12 @@ setMetrics statAddressTransactionsFull txs <- getAddressesTxs addrs =<< paramToLimits True pLimits ts <- catMaybes <$> mapM (getTransaction . txRefHash) txs - setCount (length ts) return ts scottyAddrBalance :: (MonadUnliftIO m, MonadLoggerIO m) => GetAddrBalance -> WebT m Balance scottyAddrBalance (GetAddrBalance addr) = do setMetrics statAddressBalance - setCount 1 getDefaultBalance addr scottyAddrsBalance :: @@ -1327,7 +1289,6 @@ scottyAddrsBalance (GetAddrsBalance addrs) = do setMetrics statAddressBalance balances <- getBalances addrs - setCount (length balances) return balances scottyAddrUnspent :: @@ -1335,7 +1296,6 @@ scottyAddrUnspent (GetAddrUnspent addr pLimits) = do setMetrics statAddressUnspent unspents <- getAddressUnspents addr =<< paramToLimits False pLimits - setCount (length unspents) return unspents scottyAddrsUnspent :: @@ -1343,7 +1303,6 @@ scottyAddrsUnspent (GetAddrsUnspent addrs pLimits) = do setMetrics statAddressUnspent unspents <- getAddressesUnspents addrs =<< paramToLimits False pLimits - setCount (length unspents) return unspents -- GET XPubs -- @@ -1354,7 +1313,6 @@ setMetrics statXpub let xspec = XPubSpec xpub deriv xbals <- xPubBals xspec - setCount (length xbals) lift . runNoCache noCache $ xPubSummary xspec xbals scottyDelXPub :: (MonadUnliftIO m, MonadLoggerIO m) @@ -1364,7 +1322,6 @@ let xspec = XPubSpec xpub deriv cacheM <- lift (asks (storeCache . webStore . webConfig)) n <- lift $ withCache cacheM (cacheDelXPubs [xspec]) - setCount (fromIntegral n) return (GenericResult (n > 0)) getXPubTxs :: (MonadUnliftIO m, MonadLoggerIO m) @@ -1380,7 +1337,6 @@ scottyXPubTxs (GetXPubTxs xpub deriv plimits (NoCache nocache)) = do setMetrics statXpubTransactions txs <- getXPubTxs xpub deriv plimits nocache - setCount (length txs) return txs scottyXPubTxsFull :: @@ -1393,7 +1349,6 @@ txs <- fmap catMaybes $ lift . runNoCache nocache $ mapM (getTransaction . txRefHash) refs - setCount (length txs) return txs scottyXPubBalances :: @@ -1401,7 +1356,6 @@ scottyXPubBalances (GetXPubBalances xpub deriv (NoCache noCache)) = do setMetrics statXpubBalances balances <- filter f <$> lift (runNoCache noCache (xPubBals spec)) - setCount (length balances) return balances where spec = XPubSpec xpub deriv @@ -1417,7 +1371,6 @@ let xspec = XPubSpec xpub deriv xbals <- xPubBals xspec unspents <- lift . runNoCache noCache $ xPubUnspents xspec xbals limits - setCount (length unspents) return unspents --------------------------------------- @@ -1522,7 +1475,6 @@ bus <- lift . runConduit $ getBinfoUnspents numtxid height xspecs' addrs .| (dropWhileC mn >> takeC limit .| sinkList) - setCount (length bus) setHeaders streamEncoding (binfoUnspentsToEncoding net (BinfoUnspents bus)) where @@ -1682,7 +1634,6 @@ net <- lift $ asks (storeNetwork . webStore . webConfig) rates <- map binfoRatePrice <$> lift (getRates net code times) let hs = zipWith (convert cur aaddrs) txs (rates <> repeat 0.0) - setCount (length hs) setHeaders streamEncoding $ toEncoding hs where @@ -1754,7 +1705,6 @@ ch <- lift $ asks (storeChain . webStore . webConfig) m <- blockAtOrBefore ch t bs <- go (d t) m - setCount (length bs) streamEncoding $ toEncoding $ map toBinfoBlockInfo bs where h = fromIntegral (maxBound :: H.Timestamp) @@ -1832,9 +1782,6 @@ , getBinfoBTC = coin , getBinfoLatestBlock = block } - setCount $ sum (map length (HashMap.elems xbals)) - + HashMap.size abals - + length ftxs setHeaders streamEncoding $ binfoMultiAddrToEncoding net BinfoMultiAddr @@ -1980,7 +1927,6 @@ fromIntegral amnt , binfoRawTxs = txs } - setCount (length xbals + length txs) setHeaders streamEncoding $ binfoRawAddrToEncoding net ra compute_abook xpub xbals = @@ -2024,7 +1970,6 @@ fromIntegral amnt , binfoRawTxs = txs } - setCount (length txs) setHeaders streamEncoding $ binfoRawAddrToEncoding net ra @@ -2033,7 +1978,6 @@ setMetrics statBlockchainQgetreceivedbyaddress a <- getAddress "addr" b <- fromMaybe (zeroBalance a) <$> getBalance a - setCount 1 setHeaders S.text . cs . show $ balanceTotalReceived b @@ -2042,7 +1986,6 @@ setMetrics statBlockchainQgetsentbyaddress a <- getAddress "addr" b <- fromMaybe (zeroBalance a) <$> getBalance a - setCount 1 setHeaders S.text . cs . show $ balanceTotalReceived b - balanceAmount b - balanceZero b @@ -2051,7 +1994,6 @@ setMetrics statBlockchainQaddressbalance a <- getAddress "addr" b <- fromMaybe (zeroBalance a) <$> getBalance a - setCount 1 setHeaders S.text . cs . show $ balanceAmount b + balanceZero b @@ -2064,7 +2006,6 @@ let top = H.nodeHeight bb bot = 0 i <- go ch bb a bot top - setCount 1 setHeaders S.text . cs $ show i where @@ -2097,7 +2038,6 @@ mapM (get_addr_balance net cashaddr) (HashSet.toList addrs) xbals <- mapM (get_xspec_balance net) (HashMap.elems xspecs) let res = HashMap.fromList (abals <> xbals) - setCount (HashMap.size res) setHeaders streamEncoding $ toEncoding res where @@ -2152,7 +2092,6 @@ next_block_headers <- catMaybes <$> mapM getBlock next_block_hashes binfo_blocks <- mapM (get_binfo_blocks numtxid next_block_headers) block_headers - setCount (length binfo_blocks) setHeaders net <- lift $ asks (storeNetwork . webStore . webConfig) streamEncoding $ binfoBlocksToEncoding net binfo_blocks @@ -2183,7 +2122,6 @@ binfoHeaderTime = H.blockTimestamp (blockDataHeader best) binfoHeaderIndex = binfoHeaderTime binfoHeaderHeight = blockDataHeight best - setCount 1 streamEncoding $ toEncoding BinfoHeader{..} where get_best_block = @@ -2232,7 +2170,6 @@ else do let btxs = map (toBinfoTxSimple numtxid) txs y = toBinfoBlock b btxs nxt - setCount 1 setHeaders net <- lift $ asks (storeNetwork . webStore . webConfig) streamEncoding $ binfoBlockToEncoding net y @@ -2259,7 +2196,6 @@ tx <- getBinfoTx txid >>= \case Right t -> return t Left e -> raise e - setCount 1 if hex then hx tx else js numtxid tx where js numtxid t = do @@ -2277,7 +2213,6 @@ tx <- getBinfoTx txid >>= \case Right t -> return t Left e -> raise e - setCount 1 S.text . cs . show . sum . map outputAmount $ transactionOutputs tx scottyBinfoTxFees :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () @@ -2290,7 +2225,6 @@ let i = sum . map inputAmount . filter f $ transactionInputs tx o = sum . map outputAmount $ transactionOutputs tx - setCount 1 S.text . cs . show $ i - o where f StoreInput{} = True @@ -2308,7 +2242,6 @@ transactionInputs tx o = toInteger . sum . map outputAmount . filter (g addr) $ transactionOutputs tx - setCount 1 S.text . cs . show $ o - i where f addr StoreInput{inputAddress = Just a} = a == addr @@ -2325,7 +2258,6 @@ tx <- getBinfoTx txid >>= \case Right t -> return t Left e -> raise e - setCount 1 S.text . cs . show . sum . map inputAmount . filter f $ transactionInputs tx where f StoreInput{} = True @@ -2341,7 +2273,6 @@ let txids = map snd $ take n $ drop offset mempool txs <- catMaybes <$> mapM getTransaction txids net <- lift $ asks (storeNetwork . webStore . webConfig) - setCount (length txs) setHeaders let mem = BinfoMempool $ map (toBinfoTxSimple numtxid) txs streamEncoding $ binfoMempoolToEncoding net mem @@ -2352,7 +2283,6 @@ ch <- asks (storeChain . webStore . webConfig) bn <- chainGetBest ch setHeaders - setCount 1 S.text . cs . show $ H.nodeHeight bn scottyBinfoLatestHash :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () @@ -2360,7 +2290,6 @@ setMetrics statBlockchainQlatesthash ch <- asks (storeChain . webStore . webConfig) bn <- chainGetBest ch - setCount 1 setHeaders S.text . TL.fromStrict . H.blockHashToHex . H.headerHash $ H.nodeHeader bn @@ -2370,7 +2299,6 @@ ch <- asks (storeChain . webStore . webConfig) net <- asks (storeNetwork . webStore . webConfig) bn <- chainGetBest ch - setCount 1 setHeaders S.text . cs . show . (/ (100 * 1000 * 1000 :: Double)) . fromIntegral $ H.computeSubsidy net (H.nodeHeight bn + 1) @@ -2379,7 +2307,6 @@ scottyBinfoAddrToHash = do setMetrics statBlockchainQaddresstohash addr <- getAddress "addr" - setCount 1 setHeaders S.text . encodeHexLazy . runPutL . serialize $ getAddrHash160 addr @@ -2390,7 +2317,6 @@ net <- asks (storeNetwork . webStore . webConfig) hash <- either (const S.next) return (decode bs) addr <- maybe S.next return (addrToText net (PubKeyAddress hash)) - setCount 1 setHeaders S.text $ TL.fromStrict addr @@ -2401,7 +2327,6 @@ pubkey <- maybe S.next (return . pubKeyAddr) $ eitherToMaybe . runGetS deserialize =<< decodeHex hex net <- lift $ asks (storeNetwork . webStore . webConfig) - setCount 1 setHeaders case addrToText net pubkey of Nothing -> raise ThingNotFound @@ -2418,7 +2343,6 @@ pk <- case extr addr i of Left e -> raise $ UserError e Right t -> return t - setCount 1 setHeaders S.text $ encodeHexLazy $ L.fromStrict pk where @@ -2457,7 +2381,6 @@ addr <- case pkm of Nothing -> raise $ UserError "Could not decode public key" Just pk -> return $ pubKeyAddr pk - setCount 1 setHeaders S.text . encodeHexLazy . runPutL . serialize $ getAddrHash160 addr @@ -2471,7 +2394,6 @@ setMetrics statPeers peers <- lift $ getPeersInformation =<< asks (storeManager . webStore . webConfig) - setCount (length peers) return peers -- | Obtain information about connected peers from peer manager process. @@ -2502,7 +2424,6 @@ setMetrics statHealth h <- lift $ asks webConfig >>= healthCheck unless (isOK h) $ S.status status503 - setCount 1 return h blockHealthCheck :: (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) @@ -2580,7 +2501,6 @@ setHeaders db <- lift $ asks (databaseHandle . storeDB . webStore . webConfig) statsM <- lift (getProperty db Stats) - setCount 1 S.text $ maybe "Could not get stats" cs statsM ----------------------- @@ -2732,9 +2652,7 @@ 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') $ \_ -> @@ -2752,10 +2670,9 @@ b <- old_body unless (B.null b) . atomically $ modifyTVar var (<> b) return b - add_stat d i s = do + add_stat d s = do addStatQuery s addStatTime s d - addStatItems s (fromIntegral i) end var runner req t1 = do t2 <- systemToUTCTime <$> getSystemTime let diff = round $ diffUTCTime t2 t1 * 1000 @@ -2763,17 +2680,13 @@ Nothing -> return () Just m -> do let m_stat_var = V.lookup (statKey m) (vault req) - m_item_var = V.lookup (itemsKey m) (vault req) - i <- case m_item_var of - Nothing -> return 0 - Just item_var -> readTVarIO item_var - add_stat diff i (statAll m) + add_stat diff (statAll m) case m_stat_var of Nothing -> return () Just stat_var -> readTVarIO stat_var >>= \case Nothing -> return () - Just f -> add_stat diff i (f m) + Just f -> add_stat diff (f m) when (diff > 10000) $ do b <- readTVarIO var runner $ $(logWarnS) "Web" $