{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Haskoin.Store.Stats ( StatDist, withStats, createStatDist, addStatTime, addClientError, addServerError, addStatQuery, addStatItems, ) where import Control.Concurrent.STM.TQueue ( TQueue, flushTQueue, writeTQueue, ) import qualified Control.Foldl as L import Control.Monad (forever) import Data.Function (on) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.Int (Int64) import Data.List (sort, sortBy) import Data.Maybe (fromMaybe) import Data.Ord (Down (..), comparing) import Data.String.Conversions (cs) import Data.Text (Text) import System.Metrics ( Store, Value (..), newStore, registerGcMetrics, registerGroup, sampleAll, ) import System.Remote.Monitoring.Statsd ( defaultStatsdOptions, flushInterval, forkStatsd, host, port, prefix, ) import UnliftIO ( MonadIO, TVar, atomically, liftIO, modifyTVar, newTQueueIO, newTVarIO, readTVar, withAsync, ) import UnliftIO.Concurrent (threadDelay) withStats :: MonadIO m => Text -> Int -> Text -> (Store -> m a) -> m a withStats :: forall (m :: * -> *) a. MonadIO m => Text -> Int -> Text -> (Store -> m a) -> m a withStats Text h Int p Text pfx Store -> m a go = do Store store <- forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO IO Store newStore Statsd _statsd <- forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO forall a b. (a -> b) -> a -> b $ StatsdOptions -> Store -> IO Statsd forkStatsd StatsdOptions defaultStatsdOptions { prefix :: Text prefix = Text pfx, host :: Text host = Text h, port :: Int port = Int p } Store store forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO forall a b. (a -> b) -> a -> b $ Store -> IO () registerGcMetrics Store store Store -> m a go Store store data StatData = StatData { StatData -> [Int64] statTimes :: ![Int64], StatData -> Int64 statQueries :: !Int64, StatData -> Int64 statItems :: !Int64, StatData -> Int64 statClientErrors :: !Int64, StatData -> Int64 statServerErrors :: !Int64 } data StatDist = StatDist { StatDist -> TQueue Int64 distQueue :: !(TQueue Int64), StatDist -> TVar Int64 distQueries :: !(TVar Int64), StatDist -> TVar Int64 distItems :: !(TVar Int64), StatDist -> TVar Int64 distClientErrors :: !(TVar Int64), StatDist -> TVar Int64 distServerErrors :: !(TVar Int64) } createStatDist :: MonadIO m => Text -> Store -> m StatDist createStatDist :: forall (m :: * -> *). MonadIO m => Text -> Store -> m StatDist createStatDist Text t Store store = forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO forall a b. (a -> b) -> a -> b $ do TQueue Int64 distQueue <- forall (m :: * -> *) a. MonadIO m => m (TQueue a) newTQueueIO TVar Int64 distQueries <- forall (m :: * -> *) a. MonadIO m => a -> m (TVar a) newTVarIO Int64 0 TVar Int64 distItems <- forall (m :: * -> *) a. MonadIO m => a -> m (TVar a) newTVarIO Int64 0 TVar Int64 distClientErrors <- forall (m :: * -> *) a. MonadIO m => a -> m (TVar a) newTVarIO Int64 0 TVar Int64 distServerErrors <- forall (m :: * -> *) a. MonadIO m => a -> m (TVar a) newTVarIO Int64 0 let metrics :: HashMap Text (StatData -> Value) metrics = forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v HashMap.fromList [ ( Text t forall a. Semigroup a => a -> a -> a <> Text ".request_count", Int64 -> Value Counter forall b c a. (b -> c) -> (a -> b) -> a -> c . StatData -> Int64 statQueries ), ( Text t forall a. Semigroup a => a -> a -> a <> Text ".item_count", Int64 -> Value Counter forall b c a. (b -> c) -> (a -> b) -> a -> c . StatData -> Int64 statItems ), ( Text t forall a. Semigroup a => a -> a -> a <> Text ".client_errors", Int64 -> Value Counter forall b c a. (b -> c) -> (a -> b) -> a -> c . StatData -> Int64 statClientErrors ), ( Text t forall a. Semigroup a => a -> a -> a <> Text ".server_errors", Int64 -> Value Counter forall b c a. (b -> c) -> (a -> b) -> a -> c . StatData -> Int64 statServerErrors ), ( Text t forall a. Semigroup a => a -> a -> a <> Text ".mean_ms", Int64 -> Value Gauge forall b c a. (b -> c) -> (a -> b) -> a -> c . [Int64] -> Int64 mean forall b c a. (b -> c) -> (a -> b) -> a -> c . StatData -> [Int64] statTimes ), ( Text t forall a. Semigroup a => a -> a -> a <> Text ".avg_ms", Int64 -> Value Gauge forall b c a. (b -> c) -> (a -> b) -> a -> c . [Int64] -> Int64 avg forall b c a. (b -> c) -> (a -> b) -> a -> c . StatData -> [Int64] statTimes ), ( Text t forall a. Semigroup a => a -> a -> a <> Text ".max_ms", Int64 -> Value Gauge forall b c a. (b -> c) -> (a -> b) -> a -> c . [Int64] -> Int64 maxi forall b c a. (b -> c) -> (a -> b) -> a -> c . StatData -> [Int64] statTimes ), ( Text t forall a. Semigroup a => a -> a -> a <> Text ".min_ms", Int64 -> Value Gauge forall b c a. (b -> c) -> (a -> b) -> a -> c . [Int64] -> Int64 mini forall b c a. (b -> c) -> (a -> b) -> a -> c . StatData -> [Int64] statTimes ), ( Text t forall a. Semigroup a => a -> a -> a <> Text ".p90max_ms", Int64 -> Value Gauge forall b c a. (b -> c) -> (a -> b) -> a -> c . [Int64] -> Int64 p90max forall b c a. (b -> c) -> (a -> b) -> a -> c . StatData -> [Int64] statTimes ), ( Text t forall a. Semigroup a => a -> a -> a <> Text ".p90avg_ms", Int64 -> Value Gauge forall b c a. (b -> c) -> (a -> b) -> a -> c . [Int64] -> Int64 p90avg forall b c a. (b -> c) -> (a -> b) -> a -> c . StatData -> [Int64] statTimes ), ( Text t forall a. Semigroup a => a -> a -> a <> Text ".var_ms", Int64 -> Value Gauge forall b c a. (b -> c) -> (a -> b) -> a -> c . [Int64] -> Int64 var forall b c a. (b -> c) -> (a -> b) -> a -> c . StatData -> [Int64] statTimes ) ] let sd :: StatDist sd = StatDist {TVar Int64 TQueue Int64 distServerErrors :: TVar Int64 distClientErrors :: TVar Int64 distItems :: TVar Int64 distQueries :: TVar Int64 distQueue :: TQueue Int64 distServerErrors :: TVar Int64 distClientErrors :: TVar Int64 distItems :: TVar Int64 distQueries :: TVar Int64 distQueue :: TQueue Int64 ..} forall a. HashMap Text (a -> Value) -> IO a -> Store -> IO () registerGroup HashMap Text (StatData -> Value) metrics (forall (m :: * -> *). MonadIO m => StatDist -> m StatData flush StatDist sd) Store store forall (m :: * -> *) a. Monad m => a -> m a return StatDist sd toDouble :: Int64 -> Double toDouble :: Int64 -> Double toDouble = forall a b. (Integral a, Num b) => a -> b fromIntegral addStatTime :: MonadIO m => StatDist -> Int64 -> m () addStatTime :: forall (m :: * -> *). MonadIO m => StatDist -> Int64 -> m () addStatTime StatDist q = forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (m :: * -> *) a. MonadIO m => STM a -> m a atomically forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. TQueue a -> a -> STM () writeTQueue (StatDist -> TQueue Int64 distQueue StatDist q) addStatQuery :: MonadIO m => StatDist -> m () addStatQuery :: forall (m :: * -> *). MonadIO m => StatDist -> m () addStatQuery StatDist q = forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (m :: * -> *) a. MonadIO m => STM a -> m a atomically forall a b. (a -> b) -> a -> b $ forall a. TVar a -> (a -> a) -> STM () modifyTVar (StatDist -> TVar Int64 distQueries StatDist q) (forall a. Num a => a -> a -> a + Int64 1) addStatItems :: MonadIO m => StatDist -> Int64 -> m () addStatItems :: forall (m :: * -> *). MonadIO m => StatDist -> Int64 -> m () addStatItems StatDist q = forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (m :: * -> *) a. MonadIO m => STM a -> m a atomically forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. TVar a -> (a -> a) -> STM () modifyTVar (StatDist -> TVar Int64 distItems StatDist q) forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. Num a => a -> a -> a (+) addClientError :: MonadIO m => StatDist -> m () addClientError :: forall (m :: * -> *). MonadIO m => StatDist -> m () addClientError StatDist q = forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (m :: * -> *) a. MonadIO m => STM a -> m a atomically forall a b. (a -> b) -> a -> b $ forall a. TVar a -> (a -> a) -> STM () modifyTVar (StatDist -> TVar Int64 distClientErrors StatDist q) (forall a. Num a => a -> a -> a + Int64 1) addServerError :: MonadIO m => StatDist -> m () addServerError :: forall (m :: * -> *). MonadIO m => StatDist -> m () addServerError StatDist q = forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (m :: * -> *) a. MonadIO m => STM a -> m a atomically forall a b. (a -> b) -> a -> b $ forall a. TVar a -> (a -> a) -> STM () modifyTVar (StatDist -> TVar Int64 distServerErrors StatDist q) (forall a. Num a => a -> a -> a + Int64 1) flush :: MonadIO m => StatDist -> m StatData flush :: forall (m :: * -> *). MonadIO m => StatDist -> m StatData flush StatDist {TVar Int64 TQueue Int64 distServerErrors :: TVar Int64 distClientErrors :: TVar Int64 distItems :: TVar Int64 distQueries :: TVar Int64 distQueue :: TQueue Int64 distServerErrors :: StatDist -> TVar Int64 distClientErrors :: StatDist -> TVar Int64 distItems :: StatDist -> TVar Int64 distQueries :: StatDist -> TVar Int64 distQueue :: StatDist -> TQueue Int64 ..} = forall (m :: * -> *) a. MonadIO m => STM a -> m a atomically forall a b. (a -> b) -> a -> b $ do [Int64] statTimes <- forall a. TQueue a -> STM [a] flushTQueue TQueue Int64 distQueue Int64 statQueries <- forall a. TVar a -> STM a readTVar TVar Int64 distQueries Int64 statItems <- forall a. TVar a -> STM a readTVar TVar Int64 distItems Int64 statClientErrors <- forall a. TVar a -> STM a readTVar TVar Int64 distClientErrors Int64 statServerErrors <- forall a. TVar a -> STM a readTVar TVar Int64 distServerErrors forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ StatData {Int64 [Int64] statServerErrors :: Int64 statClientErrors :: Int64 statItems :: Int64 statQueries :: Int64 statTimes :: [Int64] statServerErrors :: Int64 statClientErrors :: Int64 statItems :: Int64 statQueries :: Int64 statTimes :: [Int64] ..} average :: Fractional a => L.Fold a a average :: forall a. Fractional a => Fold a a average = forall a. Fractional a => a -> a -> a (/) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall a. Num a => Fold a a L.sum forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> forall b a. Num b => Fold a b L.genericLength avg :: [Int64] -> Int64 avg :: [Int64] -> Int64 avg = forall a b. (RealFrac a, Integral b) => a -> b round forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (f :: * -> *) a b. Foldable f => Fold a b -> f a -> b L.fold forall a. Fractional a => Fold a a average forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a -> b) -> [a] -> [b] map Int64 -> Double toDouble mean :: [Int64] -> Int64 mean :: [Int64] -> Int64 mean = forall a b. (RealFrac a, Integral b) => a -> b round forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (f :: * -> *) a b. Foldable f => Fold a b -> f a -> b L.fold forall a. Fractional a => Fold a a L.mean forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a -> b) -> [a] -> [b] map Int64 -> Double toDouble maxi :: [Int64] -> Int64 maxi :: [Int64] -> Int64 maxi = forall a. a -> Maybe a -> a fromMaybe Int64 0 forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (f :: * -> *) a b. Foldable f => Fold a b -> f a -> b L.fold forall a. Ord a => Fold a (Maybe a) L.maximum mini :: [Int64] -> Int64 mini :: [Int64] -> Int64 mini = forall a. a -> Maybe a -> a fromMaybe Int64 0 forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (f :: * -> *) a b. Foldable f => Fold a b -> f a -> b L.fold forall a. Ord a => Fold a (Maybe a) L.minimum var :: [Int64] -> Int64 var :: [Int64] -> Int64 var = forall a b. (RealFrac a, Integral b) => a -> b round forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (f :: * -> *) a b. Foldable f => Fold a b -> f a -> b L.fold forall a. Fractional a => Fold a a L.variance forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a -> b) -> [a] -> [b] map Int64 -> Double toDouble p90max :: [Int64] -> Int64 p90max :: [Int64] -> Int64 p90max [Int64] ls = case [Int64] chopped of [] -> Int64 0 Int64 h : [Int64] _ -> Int64 h where sorted :: [Int64] sorted = forall a. (a -> a -> Ordering) -> [a] -> [a] sortBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering comparing forall a. a -> Down a Down) [Int64] ls len :: Int len = forall (t :: * -> *) a. Foldable t => t a -> Int length [Int64] sorted chopped :: [Int64] chopped = forall a. Int -> [a] -> [a] drop (forall (t :: * -> *) a. Foldable t => t a -> Int length [Int64] sorted forall a. Num a => a -> a -> a * Int 1 forall a. Integral a => a -> a -> a `div` Int 10) [Int64] sorted p90avg :: [Int64] -> Int64 p90avg :: [Int64] -> Int64 p90avg [Int64] ls = [Int64] -> Int64 avg [Int64] chopped where sorted :: [Int64] sorted = forall a. (a -> a -> Ordering) -> [a] -> [a] sortBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering comparing forall a. a -> Down a Down) [Int64] ls len :: Int len = forall (t :: * -> *) a. Foldable t => t a -> Int length [Int64] sorted chopped :: [Int64] chopped = forall a. Int -> [a] -> [a] drop (forall (t :: * -> *) a. Foldable t => t a -> Int length [Int64] sorted forall a. Num a => a -> a -> a * Int 1 forall a. Integral a => a -> a -> a `div` Int 10) [Int64] sorted