├── .gitignore ├── CONTRIBUTORS.md ├── LICENSE ├── README.md ├── Setup.hs ├── metrics.cabal ├── src └── Data │ ├── HealthCheck.hs │ ├── Metrics.hs │ └── Metrics │ ├── Counter.hs │ ├── Gauge.hs │ ├── Histogram.hs │ ├── Histogram │ └── Internal.hs │ ├── Internal.hs │ ├── Meter.hs │ ├── Meter │ └── Internal.hs │ ├── MovingAverage.hs │ ├── MovingAverage │ └── ExponentiallyWeighted.hs │ ├── Registry.hs │ ├── Reporter │ └── StdOut.hs │ ├── Reservoir.hs │ ├── Reservoir │ ├── ExponentiallyDecaying.hs │ └── Uniform.hs │ ├── Snapshot.hs │ ├── Timer.hs │ ├── Timer │ └── Internal.hs │ └── Types.hs ├── stack.yaml └── tests ├── CounterTest.hs ├── EDR.hs ├── EWMA.hs ├── GaugeTest.hs ├── HistogramTest.hs ├── Main.hs ├── MeterTest.hs ├── RegistryTest.hs └── TimerTest.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | cabal-dev 3 | *.o 4 | *.hi 5 | *.chi 6 | *.chs.h 7 | .virthualenv 8 | .stack-work/ 9 | -------------------------------------------------------------------------------- /CONTRIBUTORS.md: -------------------------------------------------------------------------------- 1 | Contributors 2 | ============ 3 | Ian Duncan - Original author 4 | Josh Bohde - Space leak fix 5 | 6 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2013 SaneTracker 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy of 6 | this software and associated documentation files (the "Software"), to deal in 7 | the Software without restriction, including without limitation the rights to 8 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of 9 | the Software, and to permit persons to whom the Software is furnished to do so, 10 | subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS 17 | FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR 18 | COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER 19 | IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 20 | CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Metrics 2 | 3 | [![Hackage](https://budueba.com/hackage/metrics)](https://hackage.haskell.org/package/metrics) 4 | ![License](https://img.shields.io/github/license/iand675/metrics.svg?style=flat) 5 | [![Circle CI](https://circleci.com/gh/iand675/metrics/tree/master.svg?style=svg)](https://circleci.com/gh/iand675/metrics/tree/master) 6 | 7 | ## Metrics is a port of the eponymous [Java library](https://dropwizard.github.io/metrics/3.1.0/) to help you understand what your code is doing in production. 8 | 9 | Metrics provides a set of measurement tools for various scenarios: 10 | 11 | * Counters - a simple count events by incrementing or decrementing 12 | * Gauges - instantaneous measurements of values for charting purposes 13 | * Histograms - measure statistics about program behavior, such as min, mean, max, standard deviation, median, quantiles... 14 | * Meters - measure the rate at which events occur 15 | * Timers - a combined histogram and meter for recording event duration and rate of occurence 16 | 17 | ## Contributing 18 | 19 | PRs are welcome! 20 | Issues are located in the GitHub issue tracker. 21 | 22 | Areas that could use contributions: 23 | 24 | * Performance improvements for metrics under high contention 25 | * Any area that's missing parity with the Java library & makes sense for Haskell 26 | * Examples in the docs 27 | * More reporters! Would pretty much auto-merge support for: 28 | - [ ] [Datadog](https://github.com/iand675/datadog) 29 | - [ ] StatsD 30 | - [ ] Riemann 31 | - [ ] Librato 32 | - [ ] Graphite 33 | - [ ] InfluxDB 34 | - [ ] ... anything else I've forgotten that's reasonably popular 35 | * WAI middleware 36 | * http-client integration 37 | * persistent / postgresql-simple integration 38 | * Automatic tracking for RTS / GC metrics 39 | 40 | ## License 41 | 42 | Copyright (c) 2013-2017 Ian Duncan 43 | 44 | Published under MIT License, see LICENSE 45 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /metrics.cabal: -------------------------------------------------------------------------------- 1 | -- Initial submarine-metrics.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: metrics 5 | version: 0.4.1.1 6 | synopsis: High-performance application metric tracking 7 | description: 8 | A port of Coda Hale's excellent metrics library for the JVM 9 | . 10 | 11 | . 12 | For motivation about why you might want to track application metrics, check Coda\'s talk: 13 | . 14 | 15 | . 16 | Interesting portions of this package's documentation were also appropriated from the metrics library's documentation: 17 | . 18 | 19 | license: MIT 20 | license-file: LICENSE 21 | author: Ian Duncan 22 | maintainer: ian@iankduncan.com 23 | -- copyright: 24 | category: Data 25 | build-type: Simple 26 | -- extra-source-files: 27 | cabal-version: >=1.10 28 | source-repository head 29 | type: git 30 | location: http://github.com/iand675/metrics 31 | 32 | library 33 | exposed-modules: Data.HealthCheck 34 | Data.Metrics, 35 | Data.Metrics.Counter, 36 | Data.Metrics.Gauge, 37 | Data.Metrics.Histogram, 38 | Data.Metrics.Histogram.Internal, 39 | Data.Metrics.Internal, 40 | Data.Metrics.MovingAverage, 41 | Data.Metrics.MovingAverage.ExponentiallyWeighted, 42 | Data.Metrics.Meter, 43 | Data.Metrics.Meter.Internal, 44 | Data.Metrics.Timer, 45 | Data.Metrics.Timer.Internal, 46 | Data.Metrics.Reporter.StdOut, 47 | Data.Metrics.Reservoir, 48 | Data.Metrics.Reservoir.ExponentiallyDecaying, 49 | Data.Metrics.Reservoir.Uniform, 50 | Data.Metrics.Snapshot, 51 | Data.Metrics.Registry, 52 | Data.Metrics.Types 53 | 54 | -- other-modules: 55 | other-extensions: TypeFamilies, 56 | MultiParamTypeClasses, 57 | FunctionalDependencies, 58 | TemplateHaskell, 59 | TypeSynonymInstances, 60 | FlexibleInstances, 61 | FlexibleContexts, 62 | UndecidableInstances 63 | 64 | build-depends: base >=4.8 && < 5, 65 | unordered-containers, 66 | text, 67 | transformers, 68 | vector, 69 | primitive, 70 | mwc-random, 71 | transformers-base, 72 | vector-algorithms, 73 | containers, 74 | time, 75 | unix-compat, 76 | lens, 77 | ansi-terminal, 78 | bytestring 79 | hs-source-dirs: src 80 | default-language: Haskell2010 81 | 82 | test-suite tests 83 | main-is: Main.hs 84 | other-modules: CounterTest, EDR, EWMA, GaugeTest, HistogramTest, MeterTest, RegistryTest, TimerTest 85 | hs-source-dirs: tests 86 | type: exitcode-stdio-1.0 87 | build-depends: base, 88 | metrics, 89 | async, 90 | mwc-random, 91 | HUnit, 92 | QuickCheck, 93 | primitive, 94 | lens 95 | default-language: Haskell2010 96 | ghc-options: -rtsopts -threaded -with-rtsopts=-N 97 | 98 | -------------------------------------------------------------------------------- /src/Data/HealthCheck.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Data.HealthCheck 3 | -- Copyright : (c) Ian Duncan 2013 4 | -- Stability : experimental 5 | -- Portability : non-portable 6 | -- 7 | -- A simple interface through which simple status dashboards can be built. 8 | -- 9 | -- > import Data.HealthCheck 10 | -- > import Data.Metrics.Reporter.StdOut 11 | -- > 12 | -- > healthCheck1 :: HealthCheck 13 | -- > healthCheck1 = healthCheck "benign_warm_fuzzy_thing" $ 14 | -- > return $ StatusReport Good Nothing 15 | -- > 16 | -- > healthCheck2 :: HealthCheck 17 | -- > healthCheck2 = healthCheck "nuclear_missile_launcher" $ 18 | -- > return $ StatusReport Ugly $ Just "out of missiles" 19 | -- > 20 | -- > main :: IO () 21 | -- > main = printHealthChecks [ healthCheck1, healthCheck2 ] 22 | -- 23 | module Data.HealthCheck ( 24 | HealthCheck(..), 25 | HealthChecks, 26 | healthCheck, 27 | Status(..), 28 | StatusReport(..) 29 | ) where 30 | import Data.Text (Text) 31 | 32 | -- | Clean up type signatures for bundling sets of health checks for reporting 33 | type HealthChecks = [HealthCheck] 34 | 35 | -- | A simple discrete health reporter 36 | data HealthCheck = HealthCheck 37 | { healthCheckStatusReport :: IO StatusReport -- ^ An action which determines the current status of the health check 38 | , healthCheckName :: Text -- ^ A unique identifier for the health check 39 | } 40 | 41 | -- | Provides a simple status reporting mechanism for checking application health at a glance. 42 | data Status 43 | = Good -- ^ Everything appears to be going well. 44 | | Bad -- ^ Something is broken. 45 | | Ugly -- ^ There is some sort of non-critical issue that deserves attention. 46 | | Unknown 47 | -- ^ There is no information, either good or bad, at the moment. 48 | -- An example of this might be something like a loss of network connectivity to a non-crucial service. 49 | deriving (Read, Show, Eq, Ord) 50 | 51 | -- | A report on the current status of a subsystem. 52 | data StatusReport = StatusReport 53 | { status :: Status -- ^ Current status 54 | , statusMessage :: Maybe Text -- ^ An optional message to display about the current status. 55 | } deriving (Show) 56 | 57 | -- | Create a health check. 58 | healthCheck :: Text -> IO StatusReport -> HealthCheck 59 | healthCheck = flip HealthCheck 60 | 61 | -------------------------------------------------------------------------------- /src/Data/Metrics.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | -- | 3 | -- Module : Data.Metrics 4 | -- Copyright : (c) Ian Duncan 2013 5 | -- Stability : experimental 6 | -- Portability : non-portable 7 | -- 8 | -- A library for tracking arbitrary metrics over time. 9 | -- The library largely provides pure and stateful versions of 10 | -- the same set of functionality for common metric types. 11 | -- 12 | module Data.Metrics ( 13 | module Data.HealthCheck, 14 | module Data.Metrics.Counter, 15 | module Data.Metrics.Gauge, 16 | module Data.Metrics.Histogram, 17 | module Data.Metrics.Meter, 18 | module Data.Metrics.Registry, 19 | module Data.Metrics.Timer, 20 | module Data.Metrics.Types 21 | ) where 22 | import Data.HealthCheck 23 | import Data.Metrics.Counter 24 | import Data.Metrics.Gauge 25 | import Data.Metrics.Histogram 26 | import Data.Metrics.Meter 27 | import Data.Metrics.Registry 28 | import Data.Metrics.Timer 29 | import Data.Metrics.Types 30 | 31 | {- 32 | getOrInit :: (Typeable a, MetricOutput a) => MetricRegistry -> Text -> a -> IO (Maybe (IORef a)) 33 | getOrInit r name conv defaultValue = do 34 | hm <- takeMVar $ metrics r 35 | case H.lookup name hm of 36 | Nothing -> do 37 | ref <- newIORef defaultValue 38 | let getRep = readIORef ref >>= conv 39 | putMVar (metrics r) $! H.insert name (getRep, toDyn ref) hm 40 | return $! Just ref 41 | Just (_, ref) -> do 42 | putMVar (metrics r) hm 43 | return $! fromDynamic ref 44 | -} 45 | 46 | {- 47 | counter :: MonadIO m => MetricRegistry -> Text -> m (Maybe Counter) 48 | counter registry conv name = do 49 | mref <- liftIO $ getOrInit registry name (return . conv) 0 50 | case mref of 51 | Nothing -> return Nothing 52 | Just ref -> return $! Just $! Counter ref 53 | 54 | gauge :: Typeable a => MetricRegistry -> Text -> IO a -> IO (Maybe (Gauge a)) 55 | gauge registry conv name g = do 56 | mref <- liftIO $ getOrInit registry name (fmap conv) g 57 | case mref of 58 | Nothing -> return Nothing 59 | Just ref -> return $! Just $! Gauge ref 60 | 61 | cache :: DiffTime -> Gauge a -> m () 62 | DerivativeGauge 63 | ExponentiallyWeightedMovingAverage 64 | ExponentiallyDecayingReservoir 65 | 66 | data Ratio = Ratio 67 | { numerator :: IORef Double 68 | , denominator :: IORef Double 69 | } 70 | 71 | newtype RatioGauge = Gauge Ratio 72 | Reservoir 73 | SlidingTimeWindowReservoir 74 | 75 | cachedGauge 76 | derivedGauge 77 | -} 78 | 79 | --test = do 80 | -- r <- newMetricRegistry 81 | -- (Just c) <- register r "wombats.sighted" counter 82 | -- (Just c2) <- register r "wombats.sighted" counter 83 | -- increment c 84 | -- value c >>= print 85 | -- value c2 >>= print 86 | 87 | -------------------------------------------------------------------------------- /src/Data/Metrics/Counter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | -- | 5 | -- Module : Data.Metrics.Counter 6 | -- Copyright : (c) Ian Duncan 2013 7 | -- Stability : experimental 8 | -- Portability : non-portable 9 | -- 10 | -- An incrementing and decrementing counter metric 11 | -- 12 | -- > import Data.Metrics.Counter 13 | -- > 14 | -- > main :: IO () 15 | -- > main = do 16 | -- > c <- counter 17 | -- > increment c 18 | -- > x <- value c 19 | -- > print $ x == 1 20 | -- 21 | module Data.Metrics.Counter ( 22 | Counter, 23 | counter, 24 | increment, 25 | increment', 26 | decrement, 27 | decrement', 28 | module Data.Metrics.Types 29 | ) where 30 | import Control.Monad.Base 31 | import Control.Monad.Primitive 32 | import qualified Data.HashMap.Strict as H 33 | import Data.Metrics.Internal 34 | import Data.Metrics.Types 35 | import Data.Primitive.MutVar 36 | 37 | -- | A basic atomic counter. 38 | newtype Counter m = Counter { fromCounter :: MV m Int } 39 | 40 | instance (MonadBase b m, PrimMonad b) => Count b m (Counter b) where 41 | count (Counter ref) = liftBase $ readMutVar ref 42 | {-# INLINEABLE count #-} 43 | 44 | instance (MonadBase b m, PrimMonad b) => Value b m (Counter b) Int where 45 | value (Counter ref) = liftBase $ readMutVar ref 46 | {-# INLINEABLE value #-} 47 | 48 | instance (MonadBase b m, PrimMonad b) => Set b m (Counter b) Int where 49 | set (Counter ref) x = liftBase $ updateRef ref (const x) 50 | {-# INLINEABLE set #-} 51 | 52 | instance (MonadBase b m, PrimMonad b) => Clear b m (Counter b) where 53 | clear c = set c 0 54 | {-# INLINEABLE clear #-} 55 | 56 | -- | Create a new counter. 57 | counter :: (MonadBase b m, PrimMonad b) => m (Counter b) 58 | counter = liftBase $ fmap Counter $ newMutVar 0 59 | {-# INLINEABLE counter #-} 60 | 61 | -- | Bump up a counter by 1. 62 | increment :: PrimMonad m => Counter m -> m () 63 | increment = flip increment' 1 64 | {-# INLINEABLE increment #-} 65 | 66 | -- | Add an arbitrary amount to a counter. 67 | increment' :: PrimMonad m => Counter m -> Int -> m () 68 | increment' (Counter ref) x = updateRef ref (+ x) 69 | {-# INLINEABLE increment' #-} 70 | 71 | -- | Decrease the value of a counter by 1. 72 | decrement :: PrimMonad m => Counter m -> m () 73 | decrement = flip decrement' 1 74 | {-# INLINEABLE decrement #-} 75 | 76 | -- | Subtract an arbitrary amount from a counter. 77 | decrement' :: PrimMonad m => Counter m -> Int -> m () 78 | decrement' (Counter ref) x = updateRef ref (subtract x) 79 | {-# INLINEABLE decrement' #-} 80 | 81 | -------------------------------------------------------------------------------- /src/Data/Metrics/Gauge.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | -- | A module representing a "Gauge", which is simply an action that returns the instantaneous measure of a value for charting. 5 | -- 6 | -- The action that provides the gauge's value may be replaced using "set", or read using "value". 7 | -- 8 | -- @ 9 | -- gaugeExample = do 10 | -- g <- gauge $ return 1 11 | -- x <- value g 12 | -- set g $ return 2 13 | -- y <- value g 14 | -- return (x == 1 && y == 2) 15 | -- @ 16 | module Data.Metrics.Gauge ( 17 | Gauge, 18 | gauge, 19 | ratio, 20 | module Data.Metrics.Types 21 | ) where 22 | import Control.Applicative 23 | import Control.Monad 24 | import Control.Monad.Base 25 | import Control.Monad.Primitive 26 | import Data.Metrics.Internal 27 | import Data.Metrics.Types 28 | import Data.Primitive.MutVar 29 | 30 | -- | An instantaneous measure of a value. 31 | newtype Gauge m = Gauge { fromGauge :: MV m (m Double) } 32 | 33 | -- | Create a new gauge from the given action. 34 | gauge :: (MonadBase b m, PrimMonad b) => b Double -> m (Gauge b) 35 | gauge m = do 36 | r <- liftBase $ newMutVar m 37 | return $ Gauge r 38 | 39 | instance (MonadBase b m, PrimMonad b) => Value b m (Gauge b) Double where 40 | value (Gauge r) = liftBase $ join $ readMutVar r 41 | {-# INLINEABLE value #-} 42 | 43 | instance (MonadBase b m, PrimMonad b) => Set b m (Gauge b) (b Double) where 44 | set (Gauge r) = liftBase . updateRef r . const 45 | {-# INLINEABLE set #-} 46 | 47 | -- | Compose multiple actions to create a ratio. Useful for graphing percentage information, e. g. 48 | -- 49 | -- @ 50 | -- connectionUtilizationRate :: IO (Gauge IO) 51 | -- connectionUtilizationRate = gauge $ ratio openConnectionCount $ return connectionPoolSize 52 | -- @ 53 | ratio :: Applicative f => f Double -> f Double -> f Double 54 | ratio x y = (/) <$> x <*> y 55 | 56 | -------------------------------------------------------------------------------- /src/Data/Metrics/Histogram.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE UndecidableInstances #-} 5 | -- | Histogram metrics allow you to measure not just easy things like the min, mean, max, and standard deviation of values, but also quantiles like the median or 95th percentile. 6 | -- 7 | -- Traditionally, the way the median (or any other quantile) is calculated is to take the entire data set, sort it, and take the value in the middle (or 1% from the end, for the 99th percentile). This works for small data sets, or batch processing systems, but not for high-throughput, low-latency services. 8 | -- 9 | -- The solution for this is to sample the data as it goes through. By maintaining a small, manageable reservoir which is statistically representative of the data stream as a whole, we can quickly and easily calculate quantiles which are valid approximations of the actual quantiles. This technique is called reservoir sampling. 10 | module Data.Metrics.Histogram ( 11 | Histogram, 12 | histogram, 13 | exponentiallyDecayingHistogram, 14 | uniformHistogram, 15 | uniformSampler, 16 | module Data.Metrics.Types 17 | ) where 18 | import Control.Monad.Base 19 | import Control.Monad.Primitive 20 | import qualified Data.Metrics.Histogram.Internal as P 21 | import Data.Metrics.Internal 22 | import Data.Metrics.Types 23 | import Data.Metrics.Reservoir (Reservoir) 24 | import Data.Metrics.Reservoir.Uniform (unsafeReservoir) 25 | import Data.Metrics.Reservoir.ExponentiallyDecaying (reservoir) 26 | import Data.Primitive.MutVar 27 | import Data.Time.Clock 28 | import Data.Time.Clock.POSIX 29 | import System.Random.MWC 30 | 31 | -- | A measure of the distribution of values in a stream of data. 32 | data Histogram m = Histogram 33 | { fromHistogram :: !(MV m P.Histogram) 34 | , histogramGetSeconds :: !(m NominalDiffTime) 35 | } 36 | 37 | instance (MonadBase b m, PrimMonad b) => Clear b m (Histogram b) where 38 | clear h = liftBase $ do 39 | t <- histogramGetSeconds h 40 | updateRef (fromHistogram h) $ P.clear t 41 | {-# INLINEABLE clear #-} 42 | 43 | instance (MonadBase b m, PrimMonad b) => Update b m (Histogram b) Double where 44 | update h x = liftBase $ do 45 | t <- histogramGetSeconds h 46 | updateRef (fromHistogram h) $ P.update x t 47 | {-# INLINEABLE update #-} 48 | 49 | instance (MonadBase b m, PrimMonad b) => Count b m (Histogram b) where 50 | count h = liftBase $ fmap P.count $ readMutVar (fromHistogram h) 51 | {-# INLINEABLE count #-} 52 | 53 | instance (MonadBase b m, PrimMonad b) => Statistics b m (Histogram b) where 54 | mean h = liftBase $ applyWithRef (fromHistogram h) P.mean 55 | {-# INLINEABLE mean #-} 56 | 57 | stddev h = liftBase $ applyWithRef (fromHistogram h) P.stddev 58 | {-# INLINEABLE stddev #-} 59 | 60 | variance h = liftBase $ applyWithRef (fromHistogram h) P.variance 61 | {-# INLINEABLE variance #-} 62 | 63 | maxVal h = liftBase $ fmap P.maxVal $ readMutVar (fromHistogram h) 64 | {-# INLINEABLE maxVal #-} 65 | 66 | minVal h = liftBase $ fmap P.minVal $ readMutVar (fromHistogram h) 67 | {-# INLINEABLE minVal #-} 68 | 69 | instance (MonadBase b m, PrimMonad b) => TakeSnapshot b m (Histogram b) where 70 | snapshot h = liftBase $ applyWithRef (fromHistogram h) P.snapshot 71 | {-# INLINEABLE snapshot #-} 72 | 73 | -- | Create a histogram using a custom time data supplier function and a custom reservoir. 74 | histogram :: (MonadBase b m, PrimMonad b) => b NominalDiffTime -> Reservoir -> m (Histogram b) 75 | histogram t r = do 76 | v <- liftBase $ newMutVar $ P.histogram r 77 | return $ Histogram v t 78 | 79 | -- | A histogram that gives all entries an equal likelihood of being evicted. 80 | -- 81 | -- Probably not what you want for most time-series data. 82 | uniformHistogram :: MonadBase IO m => Seed -> m (Histogram IO) 83 | uniformHistogram s = liftBase $ histogram getPOSIXTime $ unsafeReservoir s 1028 84 | 85 | -- | The recommended histogram type. It provides a fast histogram that 86 | -- probabilistically evicts older entries using a weighting system. This 87 | -- ensures that snapshots remain relatively fresh. 88 | exponentiallyDecayingHistogram :: MonadBase IO m => m (Histogram IO) 89 | exponentiallyDecayingHistogram = liftBase $ do 90 | t <- getPOSIXTime 91 | s <- createSystemRandom >>= save 92 | histogram getPOSIXTime $ reservoir 0.015 1028 t s 93 | 94 | uniformSampler :: Seed -> P.Histogram 95 | uniformSampler s = P.histogram (unsafeReservoir s 1028) 96 | 97 | -------------------------------------------------------------------------------- /src/Data/Metrics/Histogram/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | -- | The pure interface for histograms. 3 | -- This module is typically not as useful as the stateful implementation 4 | -- since reservoir updates require retrieving the current time. 5 | module Data.Metrics.Histogram.Internal ( 6 | Histogram, 7 | histogram, 8 | clear, 9 | update, 10 | mean, 11 | stddev, 12 | variance, 13 | minVal, 14 | maxVal, 15 | count, 16 | snapshot 17 | ) where 18 | import Data.Time.Clock 19 | import qualified Data.Metrics.Reservoir as R 20 | import Data.Metrics.Snapshot (Snapshot) 21 | 22 | -- | A pure histogram that maintains a bounded reservoir of samples and basic statistical data about the samples. 23 | data Histogram = Histogram 24 | { histogramReservoir :: !R.Reservoir 25 | , histogramCount :: {-# UNPACK #-} !Int 26 | , histogramMinVal :: {-# UNPACK #-} !Double 27 | , histogramMaxVal :: {-# UNPACK #-} !Double 28 | , histogramSum :: {-# UNPACK #-} !Double 29 | , histogramVariance :: {-# UNPACK #-} !(Double, Double) 30 | } 31 | 32 | -- | Create a histogram using a custom reservoir. 33 | histogram :: R.Reservoir -> Histogram 34 | histogram r = Histogram r 0 nan nan 0 (0, 0) 35 | 36 | nan :: Double 37 | nan = 0 / 0 38 | 39 | -- | Reset all statistics, in addition to the underlying reservoir. 40 | clear :: NominalDiffTime -> Histogram -> Histogram 41 | clear = go 42 | where 43 | go t s = s 44 | { histogramReservoir = R.clear t $ histogramReservoir s 45 | , histogramCount = 0 46 | , histogramMinVal = nan 47 | , histogramMaxVal = nan 48 | , histogramSum = 0 49 | , histogramVariance = (-1, 0) 50 | } 51 | {-# INLINEABLE clear #-} 52 | 53 | -- | Update statistics and the reservoir with a new sample. 54 | update :: Double -> NominalDiffTime -> Histogram -> Histogram 55 | update = go 56 | where 57 | go v t s = s 58 | { histogramReservoir = updatedReservoir 59 | , histogramCount = updatedCount 60 | , histogramMinVal = updateMin (histogramMinVal s) v 61 | , histogramMaxVal = updateMax (histogramMaxVal s) v 62 | , histogramSum = histogramSum s + v 63 | , histogramVariance = updateVariance updatedCount v $ histogramVariance s 64 | } 65 | where 66 | updatedCount = succ $ histogramCount s 67 | updatedReservoir = R.update v t $ histogramReservoir s 68 | {-# INLINEABLE update #-} 69 | 70 | updateMin :: Double -> Double -> Double 71 | updateMin ox x = if isNaN ox || ox > x then x else ox 72 | {-# INLINE updateMin #-} 73 | 74 | updateMax :: Double -> Double -> Double 75 | updateMax ox x = if isNaN ox || ox < x then x else ox 76 | {-# INLINE updateMax #-} 77 | 78 | -- | Get the average of all samples since the histogram was created. 79 | mean :: Histogram -> Double 80 | mean = go 81 | where 82 | go s = if histogramCount s > 0 83 | then histogramSum s / fromIntegral (histogramCount s) 84 | else 0 85 | {-# INLINEABLE mean #-} 86 | 87 | -- | Get the standard deviation of all samples. 88 | stddev :: Histogram -> Double 89 | stddev = go 90 | where 91 | go s = if c > 0 92 | then sqrt $ calculateVariance c $ snd $ histogramVariance s 93 | else 0 94 | where c = histogramCount s 95 | {-# INLINEABLE stddev #-} 96 | 97 | -- | Get the variance of all samples. 98 | variance :: Histogram -> Double 99 | variance = go 100 | where 101 | go s = if c <= 1 102 | then 0 103 | else calculateVariance c $ snd $ histogramVariance s 104 | where c = histogramCount s 105 | {-# INLINEABLE variance #-} 106 | 107 | -- | Get the minimum value of all samples. 108 | minVal :: Histogram -> Double 109 | minVal = histogramMinVal 110 | 111 | -- | Get the maximum value of all samples 112 | maxVal :: Histogram -> Double 113 | maxVal = histogramMaxVal 114 | 115 | -- | Get the number of samples that the histogram has been updated with. 116 | count :: Histogram -> Int 117 | count = histogramCount 118 | 119 | -- | Get a snapshot of the current reservoir's samples. 120 | snapshot :: Histogram -> Snapshot 121 | snapshot = R.snapshot . histogramReservoir 122 | {-# INLINEABLE snapshot #-} 123 | 124 | calculateVariance :: Int -> Double -> Double 125 | calculateVariance c v = if c <= 1 then 0 else v / (fromIntegral c - 1) 126 | {-# INLINEABLE calculateVariance #-} 127 | 128 | updateVariance :: Int -> Double -> (Double, Double) -> (Double, Double) 129 | updateVariance _ !c (-1, y) = (c, 0) 130 | updateVariance count c (x, y) = (l, r) 131 | where 132 | c' = fromIntegral count 133 | diff = c - x 134 | !l = x + diff / c' 135 | !r = y + diff * (c - l) 136 | {-# INLINEABLE updateVariance #-} 137 | 138 | -------------------------------------------------------------------------------- /src/Data/Metrics/Internal.hs: -------------------------------------------------------------------------------- 1 | -- | Internal helpers that provide strict atomic MutVar access. 2 | -- 3 | -- These functions allow us to avoid the overhead of MVar as long 4 | -- as we can factor the impure sections of code out in such a way 5 | -- that the pure metric calculations can be executed without requiring 6 | -- access to multiple MutVars at a time. 7 | module Data.Metrics.Internal ( 8 | updateRef, 9 | applyWithRef, 10 | updateAndApplyToRef, 11 | MV 12 | ) where 13 | import Control.Monad.Primitive 14 | import Data.Primitive.MutVar 15 | 16 | -- | Perform a strict update on a MutVar. Pretty much identical to the strict variant of atomicModifyIORef. 17 | updateRef :: PrimMonad m => MV m a -> (a -> a) -> m () 18 | updateRef r f = do 19 | b <- atomicModifyMutVar r (\x -> let (a, b) = (f x, ()) in (a, a `seq` b)) 20 | b `seq` return b 21 | {-# INLINE updateRef #-} 22 | 23 | -- | Strictly apply a function on a MutVar while blocking other access to it. 24 | -- 25 | -- I really think this is probably not implemented correctly in terms of being excessively strict. 26 | applyWithRef :: PrimMonad m => MV m a -> (a -> b) -> m b 27 | applyWithRef r f = do 28 | b <- atomicModifyMutVar r (\x -> let app = f x in let (a, b) = (x, app) in (a, a `seq` b)) 29 | b `seq` return b 30 | {-# INLINE applyWithRef #-} 31 | 32 | -- | A function which combines the previous two, updating a value atomically 33 | -- and then returning some value calculated with the update in a single step. 34 | updateAndApplyToRef :: PrimMonad m => MV m a -> (a -> a) -> (a -> b) -> m b 35 | updateAndApplyToRef r fa fb = do 36 | b <- atomicModifyMutVar r $ \x -> 37 | let appA = fa x in 38 | let appB = fb appA in 39 | let (a, b) = (appA, appB) in 40 | (a, a `seq` b) 41 | b `seq` return b 42 | {-# INLINE updateAndApplyToRef #-} 43 | 44 | -- | MutVar (PrimState m) is a little verbose. 45 | type MV m = MutVar (PrimState m) 46 | -------------------------------------------------------------------------------- /src/Data/Metrics/Meter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | -- | A meter measures the rate at which a set of events occur: 5 | -- 6 | -- Meters measure the rate of the events in a few different ways. The mean rate is the average rate of events. It’s generally useful for trivia, but as it represents the total rate for your application’s entire lifetime (e.g., the total number of requests handled, divided by the number of seconds the process has been running), it doesn’t offer a sense of recency. Luckily, meters also record three different exponentially-weighted moving average rates: the 1-, 5-, and 15-minute moving averages. 7 | -- 8 | -- (Just like the Unix load averages visible in uptime or top.) 9 | module Data.Metrics.Meter ( 10 | Meter, 11 | meter, 12 | mark, 13 | mark', 14 | mkMeter, 15 | fromMeter, 16 | module Data.Metrics.Types 17 | ) where 18 | import Control.Lens 19 | import Control.Monad.Base 20 | import Control.Monad.Primitive 21 | import Data.Primitive.MutVar 22 | import Data.Time.Clock 23 | import Data.Time.Clock.POSIX 24 | import qualified Data.HashMap.Strict as H 25 | import Data.Metrics.Internal 26 | import qualified Data.Metrics.Meter.Internal as P 27 | import qualified Data.Metrics.MovingAverage as A 28 | import qualified Data.Metrics.MovingAverage.ExponentiallyWeighted as EWMA 29 | import Data.Metrics.Types 30 | 31 | -- | A measure of the /rate/ at which a set of events occurs. 32 | data Meter m = Meter 33 | { fromMeter :: !(MV m P.Meter) 34 | , meterGetSeconds :: !(m NominalDiffTime) 35 | } 36 | 37 | instance {- (MonadBase b m, PrimMonad b) => -} Rate IO IO (Meter IO) where 38 | oneMinuteRate m = liftBase $ do 39 | t <- meterGetSeconds m 40 | updateAndApplyToRef (fromMeter m) (P.tickIfNecessary t) (A.rate . P.oneMinuteAverage) 41 | {-# INLINEABLE oneMinuteRate #-} 42 | 43 | fiveMinuteRate m = liftBase $ do 44 | t <- meterGetSeconds m 45 | updateAndApplyToRef (fromMeter m) (P.tickIfNecessary t) (A.rate . P.fiveMinuteAverage) 46 | {-# INLINEABLE fiveMinuteRate #-} 47 | 48 | fifteenMinuteRate m = liftBase $ do 49 | t <- meterGetSeconds m 50 | updateAndApplyToRef (fromMeter m) (P.tickIfNecessary t) (A.rate . P.fifteenMinuteAverage) 51 | {-# INLINEABLE fifteenMinuteRate #-} 52 | 53 | meanRate m = liftBase $ do 54 | t <- meterGetSeconds m 55 | m' <- readMutVar (fromMeter m) 56 | applyWithRef (fromMeter m) $ P.meanRate t 57 | {-# INLINEABLE meanRate #-} 58 | 59 | instance (MonadBase b m, PrimMonad m) => Count b m (Meter m) where 60 | count = fmap (view P.count) . readMutVar . fromMeter 61 | {-# INLINEABLE count #-} 62 | 63 | -- | Register multiple occurrences of an event. 64 | mark' :: PrimMonad m => Meter m -> Int -> m () 65 | mark' m x = do 66 | t <- meterGetSeconds m 67 | updateRef (fromMeter m) (P.mark t x) 68 | {-# INLINEABLE mark' #-} 69 | 70 | -- | Register a single occurrence of an event. 71 | mark :: PrimMonad m => Meter m -> m () 72 | mark = flip mark' 1 73 | {-# INLINEABLE mark #-} 74 | 75 | -- | Create a new meter using an exponentially weighted moving average 76 | meter :: IO (Meter IO) 77 | meter = mkMeter getPOSIXTime 78 | 79 | -- | Create a meter using a custom function for retrieving the current time. 80 | -- 81 | -- This is mostly exposed for testing purposes: prefer using "meter" if possible. 82 | mkMeter :: PrimMonad m => m NominalDiffTime -> m (Meter m) 83 | mkMeter m = do 84 | t <- m 85 | v <- newMutVar $ ewmaMeter t 86 | return $! Meter v m 87 | 88 | -- | Make a pure meter using an exponentially weighted moving average 89 | ewmaMeter :: NominalDiffTime -- ^ The starting time of the meter. 90 | -> P.Meter 91 | ewmaMeter = P.meterData 5 EWMA.movingAverage 92 | 93 | -------------------------------------------------------------------------------- /src/Data/Metrics/Meter/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE FunctionalDependencies #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE TypeSynonymInstances #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | module Data.Metrics.Meter.Internal ( 9 | Meter, 10 | meterData, 11 | mark, 12 | clear, 13 | tick, 14 | meanRate, 15 | oneMinuteAverage, 16 | fiveMinuteAverage, 17 | fifteenMinuteAverage, 18 | tickIfNecessary, 19 | count, 20 | lastTick 21 | ) where 22 | import Control.Lens 23 | import Control.Lens.TH 24 | import Data.Time.Clock 25 | import qualified Data.Metrics.MovingAverage as M 26 | 27 | data Meter = Meter 28 | { meterCount :: {-# UNPACK #-} !Int 29 | , meterOneMinuteRate :: !M.MovingAverage 30 | , meterFiveMinuteRate :: !M.MovingAverage 31 | , meterFifteenMinuteRate :: !M.MovingAverage 32 | , meterStartTime :: !NominalDiffTime 33 | , meterLastTick :: !NominalDiffTime 34 | , meterTickInterval :: {-# UNPACK #-} !Double 35 | } deriving (Show) 36 | 37 | makeFields ''Meter 38 | 39 | meterData :: Double -> (Double -> Int -> M.MovingAverage) -> NominalDiffTime -> Meter 40 | meterData ti f t = Meter 41 | { meterCount = 0 42 | , meterOneMinuteRate = f ti 1 43 | , meterFiveMinuteRate = f ti 5 44 | , meterFifteenMinuteRate = f ti 15 45 | , meterStartTime = t 46 | , meterLastTick = t 47 | , meterTickInterval = ti 48 | } 49 | 50 | -- TODO: make moving average prism 51 | 52 | mark :: NominalDiffTime -> Int -> Meter -> Meter 53 | mark t c m = ticked 54 | & count +~ c 55 | & oneMinuteRate %~ updateMeter 56 | & fiveMinuteRate %~ updateMeter 57 | & fifteenMinuteRate %~ updateMeter 58 | where 59 | updateMeter = M.update $ fromIntegral c 60 | ticked = tickIfNecessary t m 61 | {-# INLINEABLE mark #-} 62 | 63 | clear :: NominalDiffTime -> Meter -> Meter 64 | clear t = 65 | (count .~ 0) . 66 | (startTime .~ t) . 67 | (lastTick .~ t) . 68 | (oneMinuteRate %~ M.clear) . 69 | (fiveMinuteRate %~ M.clear) . 70 | (fifteenMinuteRate %~ M.clear) 71 | {-# INLINEABLE clear #-} 72 | 73 | tick :: Meter -> Meter 74 | tick = (oneMinuteRate %~ M.tick) . (fiveMinuteRate %~ M.tick) . (fifteenMinuteRate %~ M.tick) 75 | {-# INLINEABLE tick #-} 76 | 77 | tickIfNecessary :: NominalDiffTime -> Meter -> Meter 78 | tickIfNecessary new d = if age >= meterTickInterval d 79 | then iterate tick (d { meterLastTick = latest }) !! truncate (age / meterTickInterval d) 80 | else d 81 | where 82 | age = realToFrac (new - meterLastTick d) 83 | swapped = meterLastTick d < new 84 | latest = Prelude.max (meterLastTick d) new 85 | {-# INLINEABLE tickIfNecessary #-} 86 | 87 | meanRate :: NominalDiffTime -> Meter -> Double 88 | meanRate t d = if c == 0 89 | then 0 90 | else fromIntegral c / elapsed 91 | where 92 | c = meterCount d 93 | start = meterStartTime d 94 | elapsed = realToFrac (t - start) 95 | {-# INLINEABLE meanRate #-} 96 | 97 | oneMinuteAverage :: Meter -> M.MovingAverage 98 | oneMinuteAverage = meterOneMinuteRate 99 | 100 | fiveMinuteAverage :: Meter -> M.MovingAverage 101 | fiveMinuteAverage = meterFiveMinuteRate 102 | 103 | fifteenMinuteAverage :: Meter -> M.MovingAverage 104 | fifteenMinuteAverage = meterFifteenMinuteRate 105 | 106 | -------------------------------------------------------------------------------- /src/Data/Metrics/MovingAverage.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification #-} 2 | 3 | -- | A pure moving average module. The interface is agnostic to the scale of time 4 | -- that the average is tracking. It is up to the specific moving average module to 5 | -- handle that functionality. 6 | module Data.Metrics.MovingAverage where 7 | 8 | -- | This type encapsulates the interface 9 | -- of the different moving average implementations in such a way that they 10 | -- can be reused without plumbing the types through the other components that 11 | -- use moving averages. Most people won't ever need to use record fields of 12 | -- this type. 13 | data MovingAverage = forall s. MovingAverage 14 | { movingAverageClear :: !(s -> s) 15 | -- ^ clear the internal state of the moving average 16 | , movingAverageUpdate :: !(Double -> s -> s) 17 | -- ^ add a new sample to the moving average 18 | , movingAverageTick :: !(s -> s) 19 | -- ^ perform any modifications of the internal state associated with the passage of a predefined interval of time. 20 | , movingAverageRate :: !(s -> Double) 21 | -- ^ get the current rate of the moving average. 22 | , movingAverageState :: !s 23 | -- ^ the internal implementation state of the moving average 24 | } 25 | 26 | instance Show MovingAverage where 27 | show (MovingAverage _ _ _ r s) = "MovingAverage {movingAverageRate = " ++ show (r s) ++ "}" 28 | 29 | -- | Reset a moving average back to a starting state. 30 | clear :: MovingAverage -> MovingAverage 31 | clear (MovingAverage c u t r s) = MovingAverage c u t r (c s) 32 | {-# INLINEABLE clear #-} 33 | 34 | -- | Get the current rate of the moving average. 35 | rate :: MovingAverage -> Double 36 | rate (MovingAverage _ _ _ r s) = r s 37 | {-# INLINEABLE rate #-} 38 | 39 | -- | Update the average based upon an interval specified by the 40 | -- moving average implementation. 41 | tick :: MovingAverage -> MovingAverage 42 | tick (MovingAverage c u t r s) = MovingAverage c u t r (t s) 43 | {-# INLINEABLE tick #-} 44 | 45 | -- | Update the average with the specified value. 46 | update :: Double -> MovingAverage -> MovingAverage 47 | update x (MovingAverage c u t r s) = MovingAverage c u t r (u x s) 48 | {-# INLINEABLE update #-} 49 | -------------------------------------------------------------------------------- /src/Data/Metrics/MovingAverage/ExponentiallyWeighted.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE FunctionalDependencies #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE TypeSynonymInstances #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | -- | An exponentially-weighted moving average. 9 | -- 10 | -- see /UNIX Load Average Part 1: How It Works/: 11 | -- 12 | -- 13 | -- 14 | -- see /UNIX Load Average Part 2: Not Your Average Average/ 15 | -- 16 | -- 17 | -- 18 | -- see Wikipedia's article on exponential moving averages: 19 | -- 20 | -- 21 | module Data.Metrics.MovingAverage.ExponentiallyWeighted ( 22 | ExponentiallyWeightedMovingAverage, 23 | new1MinuteMovingAverage, 24 | new5MinuteMovingAverage, 25 | new15MinuteMovingAverage, 26 | movingAverage, 27 | clear, 28 | rate, 29 | empty, 30 | update, 31 | tick 32 | ) where 33 | import Control.Lens 34 | import Control.Lens.TH 35 | import Control.Monad.Primitive 36 | import qualified Data.Metrics.MovingAverage as MA 37 | import Data.Metrics.Types (Minutes) 38 | 39 | -- | The internal representation of the exponentially weighted moving average. 40 | -- 41 | -- This type encapsulates the state needed for the exponentially weighted "MovingAverage" implementation. 42 | data ExponentiallyWeightedMovingAverage = ExponentiallyWeightedMovingAverage 43 | { exponentiallyWeightedMovingAverageUncounted :: {-# UNPACK #-} !Double 44 | , exponentiallyWeightedMovingAverageCurrentRate :: {-# UNPACK #-} !Double 45 | , exponentiallyWeightedMovingAverageInitialized :: !Bool 46 | , exponentiallyWeightedMovingAverageInterval :: {-# UNPACK #-} !Double 47 | , exponentiallyWeightedMovingAverageAlpha :: {-# UNPACK #-} !Double 48 | } deriving (Show) 49 | 50 | makeFields ''ExponentiallyWeightedMovingAverage 51 | 52 | makeAlpha :: Double -> Minutes -> Double 53 | makeAlpha i m = 1 - exp (negate i / 60 / fromIntegral m) 54 | {-# INLINE makeAlpha #-} 55 | 56 | -- | Create a new "MovingAverage" with 5 second tick intervals for a one-minute window. 57 | new1MinuteMovingAverage :: MA.MovingAverage 58 | new1MinuteMovingAverage = movingAverage 5 1 59 | 60 | -- | Create a new "MovingAverage" with 5 second tick intervals for a five-minute window. 61 | new5MinuteMovingAverage :: MA.MovingAverage 62 | new5MinuteMovingAverage = movingAverage 5 5 63 | 64 | -- | Create a new "MovingAverage" with 5 second tick intervals for a fifteen-minute window. 65 | new15MinuteMovingAverage :: MA.MovingAverage 66 | new15MinuteMovingAverage = movingAverage 5 15 67 | 68 | -- | Create a new "MovingAverage" with the given tick interval and averaging window. 69 | movingAverage :: Double -> Minutes -> MA.MovingAverage 70 | movingAverage i m = MA.MovingAverage 71 | { MA.movingAverageClear = clear 72 | , MA.movingAverageUpdate = update 73 | , MA.movingAverageTick = tick 74 | , MA.movingAverageRate = rate 75 | , MA.movingAverageState = empty i m 76 | } 77 | 78 | -- | Reset the moving average rate to zero. 79 | clear :: ExponentiallyWeightedMovingAverage -> ExponentiallyWeightedMovingAverage 80 | clear = (initialized .~ False) . (currentRate .~ 0) . (uncounted .~ 0) 81 | {-# INLINEABLE clear #-} 82 | 83 | -- | Get the current rate (per second) of the "ExponentiallyWeightedMovingAverage" for the given window. 84 | rate :: ExponentiallyWeightedMovingAverage -> Double 85 | rate e = e ^. currentRate 86 | {-# INLINEABLE rate #-} 87 | 88 | -- | Create a new "ExpontiallyWeightedMovingAverage" with the given tick interval and averaging window. 89 | empty :: Double -- ^ The interval in seconds between ticks 90 | -> Minutes -- ^ The duration in minutes which the moving average covers 91 | -> ExponentiallyWeightedMovingAverage 92 | empty i m = ExponentiallyWeightedMovingAverage 0 0 False i $ makeAlpha i m 93 | {-# INLINEABLE empty #-} 94 | 95 | -- | Update the moving average based upon the given value 96 | update :: Double -> ExponentiallyWeightedMovingAverage -> ExponentiallyWeightedMovingAverage 97 | update = (uncounted +~) 98 | {-# INLINEABLE update #-} 99 | 100 | -- | Update the moving average as if the given interval between ticks has passed. 101 | tick :: ExponentiallyWeightedMovingAverage -> ExponentiallyWeightedMovingAverage 102 | tick e = uncounted .~ 0 $ initialized .~ True $ updateRate e 103 | where 104 | instantRate = (e ^. uncounted) / (e ^. interval) 105 | updateRate a = if a ^. initialized 106 | then currentRate +~ ((a ^. alpha) * (instantRate - a ^. currentRate)) $ a 107 | else currentRate .~ instantRate $ a 108 | {-# INLINEABLE tick #-} 109 | -------------------------------------------------------------------------------- /src/Data/Metrics/Registry.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | -- | An interface for bundling metrics in a way that they cna be iterated over for reporting or looked up for use by code that shares the registry. 3 | module Data.Metrics.Registry ( 4 | MetricRegistry, 5 | Metric(..), 6 | Register(..), 7 | metrics, 8 | newMetricRegistry, 9 | module Data.Metrics.Types 10 | ) where 11 | import Control.Concurrent.MVar 12 | import qualified Data.HashMap.Strict as H 13 | import Data.Metrics.Counter 14 | import Data.Metrics.Gauge 15 | import Data.Metrics.Histogram 16 | import Data.Metrics.Meter 17 | import Data.Metrics.Timer 18 | import Data.Metrics.Types 19 | import Data.Text (Text) 20 | 21 | -- | Initializes a new metric registry. 22 | newMetricRegistry :: IO (MetricRegistry IO) 23 | newMetricRegistry = fmap MetricRegistry $ newMVar H.empty 24 | 25 | -- | A container that tracks all metrics registered with it. 26 | -- All forms of metrics share the same namespace in the registry. 27 | -- Consequently, attempting to replace a metric with one of a different type will fail (return Nothing from a call to `register`). 28 | data MetricRegistry m = MetricRegistry 29 | { metrics :: !(MVar (H.HashMap Text (Metric m))) 30 | } 31 | 32 | -- | A sum type of all supported metric types that reporters should be able to output. 33 | data Metric m 34 | = MetricGauge !(Gauge m) 35 | | MetricCounter !(Counter m) 36 | | MetricHistogram !(Histogram m) 37 | | MetricMeter !(Meter m) 38 | | MetricTimer !(Timer m) 39 | 40 | -- | Add a new metric to a registry or retrieve the existing metric of the same name if one exists. 41 | class Register a where 42 | -- | If possible, avoid using 'register' to frequently retrieve metrics from a global registry. The metric registry is locked any time a lookup is performed, which may cause contention. 43 | register :: MetricRegistry IO -> Text -> IO a -> IO (Maybe a) 44 | 45 | instance Register (Counter IO) where 46 | register r t m = do 47 | hm <- takeMVar $ metrics r 48 | case H.lookup t hm of 49 | Nothing -> do 50 | c <- m 51 | putMVar (metrics r) $! H.insert t (MetricCounter c) hm 52 | return $ Just c 53 | Just im -> do 54 | putMVar (metrics r) hm 55 | return $! case im of 56 | MetricCounter c -> Just c 57 | _ -> Nothing 58 | 59 | instance Register (Gauge IO) where 60 | register r t m = do 61 | hm <- takeMVar $ metrics r 62 | case H.lookup t hm of 63 | Nothing -> do 64 | g <- m 65 | putMVar (metrics r) $! H.insert t (MetricGauge g) hm 66 | return $ Just g 67 | Just im -> do 68 | putMVar (metrics r) hm 69 | return $! case im of 70 | MetricGauge r -> Just r 71 | _ -> Nothing 72 | 73 | instance Register (Histogram IO) where 74 | register r t m = do 75 | hm <- takeMVar $ metrics r 76 | case H.lookup t hm of 77 | Nothing -> do 78 | h <- m 79 | putMVar (metrics r) $! H.insert t (MetricHistogram h) hm 80 | return $ Just h 81 | Just im -> do 82 | putMVar (metrics r) hm 83 | return $! case im of 84 | MetricHistogram h -> Just h 85 | _ -> Nothing 86 | 87 | instance Register (Meter IO) where 88 | register r t m = do 89 | hm <- takeMVar $ metrics r 90 | case H.lookup t hm of 91 | Nothing -> do 92 | mv <- m 93 | putMVar (metrics r) $! H.insert t (MetricMeter mv) hm 94 | return $ Just mv 95 | Just im -> do 96 | putMVar (metrics r) hm 97 | return $! case im of 98 | MetricMeter md -> Just md 99 | _ -> Nothing 100 | 101 | instance Register (Timer IO) where 102 | register r t m = do 103 | hm <- takeMVar $ metrics r 104 | case H.lookup t hm of 105 | Nothing -> do 106 | mv <- m 107 | putMVar (metrics r) $! H.insert t (MetricTimer mv) hm 108 | return $ Just mv 109 | Just im -> do 110 | putMVar (metrics r) hm 111 | return $! case im of 112 | MetricTimer md -> Just md 113 | _ -> Nothing 114 | -------------------------------------------------------------------------------- /src/Data/Metrics/Reporter/StdOut.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | -- | Logging to stdout is primarily intended for development purposes or creating command line status tools. 3 | -- 4 | -- For more meaningful access to statistics, metrics should be sent to something like Librato or Graphite. 5 | module Data.Metrics.Reporter.StdOut ( 6 | printHealthCheck, 7 | printHealthChecks 8 | ) where 9 | import qualified Data.HashMap.Strict as H 10 | import Data.HealthCheck 11 | import Data.Metrics.Internal 12 | import Data.Metrics.Types 13 | import qualified Data.Text as T 14 | import qualified Data.Text.IO as T 15 | import System.Console.ANSI 16 | 17 | --prettyPrintMetric (m, v) = T.putStr m >> T.putStr ": " >> putStrLn (show v) 18 | 19 | --reportMetrics :: MetricRegistry -> IO () 20 | --reportMetrics m = dumpMetrics m >>= mapM_ prettyPrintMetric 21 | 22 | --dumpMetrics :: MetricRegistry -> IO [(T.Text, Double)] 23 | --dumpMetrics r = do 24 | -- ms <- readMVar $ metrics r 25 | -- -- let readRep (k, (repAction, _)) = repAction >>= \rep -> return (k, rep) 26 | -- -- mapM readRep $ H.toList ms 27 | -- return [] 28 | fg = SetColor Foreground Vivid 29 | 30 | -- | Pretty-print a single HealthCheck to the console using ANSI colors. 31 | printHealthCheck :: HealthCheck -> IO () 32 | printHealthCheck (HealthCheck m name) = do 33 | s <- m 34 | setSGR $ case status s of 35 | Good -> [fg Green] 36 | Bad -> [fg Red] 37 | Ugly -> [fg Yellow] 38 | Unknown -> [fg Cyan] 39 | T.putStr "● " 40 | setSGR [Reset] 41 | T.putStr name 42 | maybe (T.putStr "\n") (\msg -> T.putStr ": " >> T.putStrLn msg) $ statusMessage s 43 | 44 | -- | Pretty-print a list of HealthChecks to the console using ANSI colors. 45 | printHealthChecks :: HealthChecks -> IO () 46 | printHealthChecks = mapM_ printHealthCheck -------------------------------------------------------------------------------- /src/Data/Metrics/Reservoir.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification #-} 2 | -- | A reservoir is the internal storage mechanism for a "Histogram". 3 | -- It provides a generic way to store histogram values in a way that 4 | -- allows us to avoid the need to plumb the implementation type through anything 5 | -- that uses a reservoir. 6 | module Data.Metrics.Reservoir where 7 | import Data.Metrics.Snapshot 8 | import Data.Time.Clock 9 | 10 | -- | Encapsulates the internal state of a reservoir implementation. 11 | -- 12 | -- The two standard implementations are the ExponentiallyDecayingReservoir and the UniformReservoir. 13 | data Reservoir = forall s. Reservoir 14 | { reservoirClear :: !(NominalDiffTime -> s -> s) 15 | -- ^ An operation that resets a reservoir to its initial state 16 | , reservoirSize :: !(s -> Int) 17 | -- ^ Retrieve current size of the reservoir. 18 | -- This may or may not be constant depending on the specific implementation. 19 | , reservoirSnapshot :: !(s -> Snapshot) 20 | -- ^ Take snapshot of the current reservoir. 21 | -- 22 | -- The number of items in the snapshot should always match the reservoir's size. 23 | , reservoirUpdate :: !(Double -> NominalDiffTime -> s -> s) 24 | -- ^ Add a new value to the reservoir, potentially evicting old values in the prcoess. 25 | , reservoirState :: !s 26 | -- ^ The internal state of the reservoir. 27 | } 28 | 29 | -- | Reset a reservoir to its initial state. 30 | clear :: NominalDiffTime -> Reservoir -> Reservoir 31 | clear t (Reservoir c size ss u st) = Reservoir c size ss u (c t st) 32 | {-# INLINEABLE clear #-} 33 | 34 | -- | Get the current number of elements in the reservoir 35 | size :: Reservoir -> Int 36 | size (Reservoir _ size _ _ st) = size st 37 | {-# INLINEABLE size #-} 38 | 39 | -- | Get a copy of all elements in the reservoir. 40 | snapshot :: Reservoir -> Snapshot 41 | snapshot (Reservoir _ _ ss _ st) = ss st 42 | {-# INLINEABLE snapshot #-} 43 | 44 | -- | Update a reservoir with a new value. 45 | -- 46 | -- N.B. for some reservoir types, the latest value is not guaranteed to be retained in the reservoir. 47 | update :: Double -> NominalDiffTime -> Reservoir -> Reservoir 48 | update x t (Reservoir c size ss u st) = Reservoir c size ss u (u x t st) 49 | {-# INLINEABLE update #-} 50 | -------------------------------------------------------------------------------- /src/Data/Metrics/Reservoir/ExponentiallyDecaying.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE FunctionalDependencies #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE TypeSynonymInstances #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE Rank2Types #-} 9 | -- | A histogram with an exponentially decaying reservoir produces quantiles which are representative of (roughly) the last five minutes of data. 10 | -- It does so by using a forward-decaying priority reservoir with an exponential weighting towards newer data. 11 | -- Unlike the uniform reservoir, an exponentially decaying reservoir represents recent data, allowing you to know very quickly if the distribution of the data has changed. 12 | -- Timers use histograms with exponentially decaying reservoirs by default. 13 | module Data.Metrics.Reservoir.ExponentiallyDecaying ( 14 | ExponentiallyDecayingReservoir, 15 | standardReservoir, 16 | reservoir, 17 | clear, 18 | size, 19 | snapshot, 20 | rescale, 21 | update 22 | ) where 23 | import Control.Lens 24 | import Control.Lens.TH 25 | import Control.Monad.Primitive 26 | import Control.Monad.ST 27 | import Data.Time.Clock 28 | import Data.Time.Clock.POSIX 29 | import Data.Metrics.Internal 30 | import qualified Data.Map as M 31 | import qualified Data.Metrics.Reservoir as R 32 | import Data.Metrics.Snapshot (Snapshot(..), takeSnapshot) 33 | import Data.Primitive.MutVar 34 | import qualified Data.Vector.Unboxed as V 35 | import Data.Word 36 | import System.PosixCompat.Time 37 | import System.Posix.Types 38 | import System.Random.MWC 39 | 40 | -- hours in seconds 41 | baseRescaleThreshold :: Word64 42 | baseRescaleThreshold = 60 * 60 43 | 44 | -- | A forward-decaying priority reservoir 45 | -- 46 | -- 47 | data ExponentiallyDecayingReservoir = ExponentiallyDecayingReservoir 48 | { exponentiallyDecayingReservoirInnerSize :: {-# UNPACK #-} !Int 49 | , exponentiallyDecayingReservoirAlpha :: {-# UNPACK #-} !Double 50 | , exponentiallyDecayingReservoirRescaleThreshold :: {-# UNPACK #-} !Word64 51 | , exponentiallyDecayingReservoirInnerReservoir :: !(M.Map Double Double) 52 | , exponentiallyDecayingReservoirCount :: {-# UNPACK #-} !Int 53 | , exponentiallyDecayingReservoirStartTime :: {-# UNPACK #-} !Word64 54 | , exponentiallyDecayingReservoirNextScaleTime :: {-# UNPACK #-} !Word64 55 | , exponentiallyDecayingReservoirSeed :: !Seed 56 | } deriving (Show) 57 | 58 | makeFields ''ExponentiallyDecayingReservoir 59 | 60 | -- | An exponentially decaying reservoir with an alpha value of 0.015 and a 1028 sample cap. 61 | -- 62 | -- This offers a 99.9% confidence level with a 5% margin of error assuming a normal distribution, 63 | -- and an alpha factor of 0.015, which heavily biases the reservoir to the past 5 minutes of measurements. 64 | standardReservoir :: NominalDiffTime -> Seed -> R.Reservoir 65 | standardReservoir = reservoir 0.015 1028 66 | 67 | -- | Create a reservoir with a custom alpha factor and reservoir size. 68 | reservoir :: Double -- ^ alpha value 69 | -> Int -- ^ max reservoir size 70 | -> NominalDiffTime -- ^ creation time for the reservoir 71 | -> Seed -> R.Reservoir 72 | reservoir a r t s = R.Reservoir 73 | { R.reservoirClear = clear 74 | , R.reservoirSize = size 75 | , R.reservoirSnapshot = snapshot 76 | , R.reservoirUpdate = update 77 | , R.reservoirState = ExponentiallyDecayingReservoir r a baseRescaleThreshold M.empty 0 c c' s 78 | } 79 | where 80 | c = truncate t 81 | c' = c + baseRescaleThreshold 82 | 83 | -- | Reset the reservoir 84 | clear :: NominalDiffTime -> ExponentiallyDecayingReservoir -> ExponentiallyDecayingReservoir 85 | clear = go 86 | where 87 | go t c = c & startTime .~ t' & nextScaleTime .~ t'' & count .~ 0 & innerReservoir .~ M.empty 88 | where 89 | t' = truncate t 90 | t'' = t' + c ^. rescaleThreshold 91 | {-# INLINEABLE clear #-} 92 | 93 | -- | Get the current size of the reservoir. 94 | size :: ExponentiallyDecayingReservoir -> Int 95 | size = go 96 | where 97 | go r = min c s 98 | where 99 | c = r ^. count 100 | s = r ^. innerSize 101 | {-# INLINEABLE size #-} 102 | 103 | -- | Get a snapshot of the current reservoir 104 | snapshot :: ExponentiallyDecayingReservoir -> Snapshot 105 | snapshot r = runST $ do 106 | let svals = V.fromList $ M.elems $ r ^. innerReservoir 107 | mvals <- V.unsafeThaw svals 108 | takeSnapshot mvals 109 | {-# INLINEABLE snapshot #-} 110 | 111 | weight :: Double -> Word64 -> Double 112 | weight alpha t = exp (alpha * fromIntegral t) 113 | {-# INLINE weight #-} 114 | 115 | -- | \"A common feature of the above techniques—indeed, the key technique that 116 | -- allows us to track the decayed weights efficiently – is that they maintain 117 | -- counts and other quantities based on g(ti − L), and only scale by g(t − L) 118 | -- at query time. But while g(ti −L)/g(t−L) is guaranteed to lie between zero 119 | -- and one, the intermediate values of g(ti − L) could become very large. For 120 | -- polynomial functions, these values should not grow too large, and should be 121 | -- effectively represented in practice by floating point values without loss of 122 | -- precision. For exponential functions, these values could grow quite large as 123 | -- new values of (ti − L) become large, and potentially exceed the capacity of 124 | -- common floating point types. However, since the values stored by the 125 | -- algorithms are linear combinations of g values (scaled sums), they can be 126 | -- rescaled relative to a new landmark. That is, by the analysis of exponential 127 | -- decay in Section III-A, the choice of L does not affect the final result. We 128 | -- can therefore multiply each value based on L by a factor of exp(−α(L′ − L)), 129 | -- and obtain the correct value as if we had instead computed relative to a new 130 | -- landmark L′ (and then use this new L′ at query time). This can be done with 131 | -- a linear pass over whatever data structure is being used.\" 132 | rescale :: Word64 -> ExponentiallyDecayingReservoir -> ExponentiallyDecayingReservoir 133 | rescale now c = c & startTime .~ now & nextScaleTime .~ st & count .~ M.size adjustedReservoir & innerReservoir .~ adjustedReservoir 134 | where 135 | potentialScaleTime = now + baseRescaleThreshold 136 | currentScaleTime = c ^. nextScaleTime 137 | st = if potentialScaleTime > currentScaleTime then potentialScaleTime else currentScaleTime 138 | diff = now - c ^. startTime 139 | adjustKey x = x * exp (-_alpha * fromIntegral diff) 140 | adjustedReservoir = M.mapKeys adjustKey $ c ^. innerReservoir 141 | _alpha = c ^. alpha 142 | {-# INLINEABLE rescale #-} 143 | 144 | -- | Insert a new sample into the reservoir. This may cause old sample values to be evicted 145 | -- based upon the probabilistic weighting given to the key at insertion time. 146 | update :: Double -- ^ new sample value 147 | -> NominalDiffTime -- ^ time of update 148 | -> ExponentiallyDecayingReservoir 149 | -> ExponentiallyDecayingReservoir 150 | update v t c = rescaled & seed .~ s' & count .~ newCount & innerReservoir .~ addValue r 151 | where 152 | rescaled = if seconds >= c ^. nextScaleTime 153 | then rescale seconds c 154 | else c 155 | seconds = truncate t 156 | priority = weight (c ^. alpha) (seconds - c ^. startTime) / priorityDenom 157 | addValue r = if newCount <= (c ^. innerSize) 158 | then M.insert priority v r 159 | else if firstKey < priority 160 | -- it should be safe to use head here since we are over our reservoir capacity at this point 161 | -- caveat: reservoir capped at 0 max size 162 | then M.delete firstKey $ M.insertWith const priority v r 163 | else r 164 | r = c ^. innerReservoir 165 | firstKey = head $ M.keys r 166 | newCount = 1 + c ^. count 167 | (priorityDenom, s') = runST $ do 168 | g <- restore $ c ^. seed 169 | p <- uniform g 170 | s' <- save g 171 | return (p :: Double, s') 172 | {-# INLINEABLE update #-} 173 | 174 | -------------------------------------------------------------------------------- /src/Data/Metrics/Reservoir/Uniform.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE FunctionalDependencies #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE TypeSynonymInstances #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | -- | A histogram with a uniform reservoir produces quantiles which are valid for the entirely of the histogram’s lifetime. 10 | -- It will return a median value, for example, which is the median of all the values the histogram has ever been updated with. 11 | -- It does this by using an algorithm called Vitter’s R), which randomly selects values for the reservoir with linearly-decreasing probability. 12 | -- 13 | -- Use a uniform histogram when you’re interested in long-term measurements. 14 | -- Don’t use one where you’d want to know if the distribution of the underlying data stream has changed recently. 15 | module Data.Metrics.Reservoir.Uniform ( 16 | UniformReservoir, 17 | reservoir, 18 | unsafeReservoir, 19 | clear, 20 | unsafeClear, 21 | size, 22 | snapshot, 23 | update, 24 | unsafeUpdate 25 | ) where 26 | import Control.Lens 27 | import Control.Lens.TH 28 | import Control.Monad.ST 29 | import Data.Metrics.Internal 30 | import Data.Time.Clock 31 | import qualified Data.Metrics.Reservoir as R 32 | import qualified Data.Metrics.Snapshot as S 33 | import Data.Primitive.MutVar 34 | import System.Random.MWC 35 | import qualified Data.Vector.Unboxed as I 36 | import qualified Data.Vector.Unboxed.Mutable as V 37 | 38 | -- | A reservoir in which all samples are equally likely to be evicted when the reservoir is at full capacity. 39 | -- 40 | -- This is conceptually simpler than the "ExponentiallyDecayingReservoir", but at the expense of providing a less accurate sample. 41 | data UniformReservoir = UniformReservoir 42 | { uniformReservoirCount :: {-# UNPACK #-} !Int 43 | , uniformReservoirInnerReservoir :: {-# UNPACK #-} !(I.Vector Double) 44 | , uniformReservoirSeed :: {-# UNPACK #-} !Seed 45 | } 46 | 47 | makeFields ''UniformReservoir 48 | 49 | -- | Make a safe uniform reservoir. This variant provides safe access at the expense of updates costing O(n) 50 | reservoir :: Seed 51 | -> Int -- ^ maximum reservoir size 52 | -> R.Reservoir 53 | reservoir g r = R.Reservoir 54 | { R.reservoirClear = clear 55 | , R.reservoirSize = size 56 | , R.reservoirSnapshot = snapshot 57 | , R.reservoirUpdate = update 58 | , R.reservoirState = UniformReservoir 0 (I.replicate r 0) g 59 | } 60 | 61 | -- | Using this variant requires that you ensure that there is no sharing of the reservoir itself. 62 | -- 63 | -- In other words, there must only be a single point of access (an IORef, etc. that accepts some sort of modification function). 64 | -- 65 | -- In return, updating the reservoir becomes an O(1) operation and clearing the reservoir avoids extra allocations. 66 | unsafeReservoir :: Seed -> Int -> R.Reservoir 67 | unsafeReservoir g r = R.Reservoir 68 | { R.reservoirClear = unsafeClear 69 | , R.reservoirSize = size 70 | , R.reservoirSnapshot = snapshot 71 | , R.reservoirUpdate = unsafeUpdate 72 | , R.reservoirState = UniformReservoir 0 (I.replicate r 0) g 73 | } 74 | 75 | -- | Reset the reservoir to empty. 76 | clear :: NominalDiffTime -> UniformReservoir -> UniformReservoir 77 | clear = go 78 | where 79 | go _ c = c & count .~ 0 & innerReservoir %~ newRes 80 | newRes v = runST $ do 81 | v' <- I.thaw v 82 | V.set v' 0 83 | I.unsafeFreeze v' 84 | {-# INLINEABLE clear #-} 85 | 86 | -- | Reset the reservoir to empty by performing an in-place modification of the reservoir. 87 | unsafeClear :: NominalDiffTime -> UniformReservoir -> UniformReservoir 88 | unsafeClear = go 89 | where 90 | go _ c = c & count .~ 0 & innerReservoir %~ newRes 91 | newRes v = runST $ do 92 | v' <- I.unsafeThaw v 93 | V.set v' 0 94 | I.unsafeFreeze v' 95 | {-# INLINEABLE unsafeClear #-} 96 | 97 | -- | Get the current size of the reservoir 98 | size :: UniformReservoir -> Int 99 | size = go 100 | where 101 | go c = min (c ^. count) (I.length $ c ^. innerReservoir) 102 | {-# INLINEABLE size #-} 103 | 104 | -- | Take a snapshot of the reservoir by doing an in-place unfreeze. 105 | -- 106 | -- This should be safe as long as unsafe operations are performed appropriately. 107 | snapshot :: UniformReservoir -> S.Snapshot 108 | snapshot = go 109 | where 110 | go c = runST $ do 111 | v' <- I.unsafeThaw $ c ^. innerReservoir 112 | S.takeSnapshot $ V.slice 0 (size c) v' 113 | {-# INLINEABLE snapshot #-} 114 | 115 | -- | Perform an update of the reservoir by copying the internal vector. O(n) 116 | update :: Double -> NominalDiffTime -> UniformReservoir -> UniformReservoir 117 | update = go 118 | where 119 | go x _ c = c & count .~ newCount & innerReservoir .~ newRes & seed .~ newSeed 120 | where 121 | newCount = c ^. count . to succ 122 | (newSeed, newRes) = runST $ do 123 | v' <- I.thaw $ c ^. innerReservoir 124 | g <- restore $ c ^. seed 125 | if newCount <= V.length v' 126 | then V.unsafeWrite v' (c ^. count) x 127 | else do 128 | i <- uniformR (0, newCount) g 129 | if i < V.length v' 130 | then V.unsafeWrite v' i x 131 | else return () 132 | v'' <- I.unsafeFreeze v' 133 | s <- save g 134 | return (s, v'') 135 | {-# INLINEABLE update #-} 136 | 137 | -- | Perform an in-place update of the reservoir. O(1) 138 | unsafeUpdate :: Double -> NominalDiffTime -> UniformReservoir -> UniformReservoir 139 | unsafeUpdate = go 140 | where 141 | go x _ c = c & count .~ newCount & innerReservoir .~ newRes & seed .~ newSeed 142 | where 143 | newCount = c ^. count . to succ 144 | (newSeed, newRes) = runST $ do 145 | v' <- I.unsafeThaw $ c ^. innerReservoir 146 | g <- restore (uniformReservoirSeed c) 147 | if newCount <= V.length v' 148 | then V.unsafeWrite v' (c ^. count) x 149 | else do 150 | i <- uniformR (0, newCount) g 151 | if i < V.length v' 152 | then V.unsafeWrite v' i x 153 | else return () 154 | v'' <- I.unsafeFreeze v' 155 | s <- save g 156 | return (s, v'') 157 | {-# INLINEABLE unsafeUpdate #-} 158 | 159 | -------------------------------------------------------------------------------- /src/Data/Metrics/Snapshot.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | module Data.Metrics.Snapshot ( 3 | Snapshot(..), 4 | quantile, 5 | size, 6 | median, 7 | get75thPercentile, 8 | get95thPercentile, 9 | get98thPercentile, 10 | get99thPercentile, 11 | get999thPercentile, 12 | takeSnapshot 13 | ) where 14 | import Control.Monad.Primitive 15 | import Data.Vector.Algorithms.Intro 16 | import qualified Data.Vector.Unboxed as I 17 | import qualified Data.Vector.Unboxed.Mutable as V 18 | 19 | -- | A wrapper around a *sorted* vector intended for calculating quantile statistics. 20 | newtype Snapshot = Snapshot 21 | { fromSnapshot :: I.Vector Double -- ^ A sorted "Vector" of samples. 22 | } 23 | deriving (Show) 24 | 25 | medianQ :: Double 26 | medianQ = 0.5 27 | 28 | p75Q :: Double 29 | p75Q = 0.75 30 | 31 | p95Q :: Double 32 | p95Q = 0.95 33 | 34 | p98Q :: Double 35 | p98Q = 0.98 36 | 37 | p99Q :: Double 38 | p99Q = 0.99 39 | 40 | p999Q :: Double 41 | p999Q = 0.999 42 | 43 | clamp :: Double -> Double 44 | clamp x | x > 1 = 1 45 | | x < 0 = 0 46 | | otherwise = x 47 | {-# INLINE clamp #-} 48 | 49 | -- | A utility function for snapshotting data from an unsorted "MVector" of samples. 50 | -- 51 | -- NB: this function uses "unsafeFreeze" under the hood, so be sure that the vector being 52 | -- snapshotted is not used after calling this function. 53 | takeSnapshot :: PrimMonad m => V.MVector (PrimState m) Double -> m Snapshot 54 | takeSnapshot v = fmap Snapshot (V.clone v >>= \v' -> sort v' >> I.unsafeFreeze v') 55 | 56 | -- | Calculate an arbitrary quantile value for a "Snapshot". 57 | -- Values below zero or greater than one will be clamped to the range [0, 1]. 58 | -- Returns 0 if no values are in the snapshot 59 | quantile :: Double -> Snapshot -> Double 60 | quantile quant (Snapshot s) 61 | | I.length s == 0 = 0 62 | | pos > fromIntegral (I.length s) = I.last s 63 | | pos' < 1 = I.head s 64 | | otherwise = 65 | lower + (pos - fromIntegral (floor pos :: Int)) * (upper - lower) 66 | where 67 | q = clamp quant 68 | pos = q * (1 + fromIntegral (I.length s)) 69 | pos' = truncate pos 70 | lower = I.unsafeIndex s (pos' - 1) 71 | upper = I.unsafeIndex s pos' 72 | 73 | -- | Get the number of elements in a "Snapshot" 74 | size :: Snapshot -> Int 75 | size (Snapshot s) = I.length s 76 | 77 | -- | Calculate the median value of a "Snapshot" 78 | median :: Snapshot -> Double 79 | median = quantile medianQ 80 | 81 | -- | Calculate the 75th percentile of a "Snapshot" 82 | get75thPercentile :: Snapshot -> Double 83 | get75thPercentile = quantile p75Q 84 | 85 | -- | Calculate the 95th percentile of a "Snapshot" 86 | get95thPercentile :: Snapshot -> Double 87 | get95thPercentile = quantile p95Q 88 | 89 | -- | Calculate the 98th percentile of a "Snapshot" 90 | get98thPercentile :: Snapshot -> Double 91 | get98thPercentile = quantile p98Q 92 | 93 | -- | Calculate the 99th percentile of a "Snapshot" 94 | get99thPercentile :: Snapshot -> Double 95 | get99thPercentile = quantile p99Q 96 | 97 | -- | Calculate the 99.9th percentile of a "Snapshot" 98 | get999thPercentile :: Snapshot -> Double 99 | get999thPercentile = quantile p999Q 100 | 101 | 102 | -------------------------------------------------------------------------------- /src/Data/Metrics/Timer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE FunctionalDependencies #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE TypeSynonymInstances #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | -- | A timer is basically a histogram of the duration of a type of event and a meter of the rate of its occurrence. 10 | module Data.Metrics.Timer ( 11 | Timer, 12 | mkTimer, 13 | timer, 14 | time, 15 | module Data.Metrics.Types 16 | ) where 17 | import Control.Applicative 18 | import Control.Lens 19 | import Control.Lens.TH 20 | import Control.Monad.Base 21 | import Control.Monad.Primitive 22 | import qualified Data.Metrics.MovingAverage.ExponentiallyWeighted as E 23 | import qualified Data.Metrics.Histogram.Internal as H 24 | import qualified Data.Metrics.Meter.Internal as M 25 | import qualified Data.Metrics.Timer.Internal as P 26 | import qualified Data.Metrics.Reservoir.ExponentiallyDecaying as R 27 | import Data.Metrics.Internal 28 | import Data.Metrics.Types 29 | import Data.Primitive.MutVar 30 | import Data.Time.Clock 31 | import Data.Time.Clock.POSIX 32 | import System.Random.MWC 33 | 34 | -- | A measure of time statistics for the duration of an event 35 | data Timer m = Timer 36 | { fromTimer :: !(MutVar (PrimState m) P.Timer) 37 | -- ^ A reference to the pure timer internals 38 | , timerGetTime :: !(m NominalDiffTime) 39 | -- ^ The function that provides time differences for the timer. In practice, this is usually just "getPOSIXTime" 40 | } 41 | 42 | makeFields ''Timer 43 | 44 | instance (MonadBase b m, PrimMonad b) => Clear b m (Timer b) where 45 | clear t = liftBase $ do 46 | ts <- timerGetTime t 47 | updateRef (fromTimer t) $ P.clear ts 48 | 49 | instance (MonadBase b m, PrimMonad b) => Update b m (Timer b) Double where 50 | update t x = liftBase $ do 51 | ts <- timerGetTime t 52 | updateRef (fromTimer t) $ P.update ts x 53 | 54 | instance (MonadBase b m, PrimMonad b) => Count b m (Timer b) where 55 | count t = liftBase $ fmap P.count $ readMutVar (fromTimer t) 56 | 57 | instance (MonadBase b m, PrimMonad b) => Statistics b m (Timer b) where 58 | mean t = liftBase $ applyWithRef (fromTimer t) P.mean 59 | stddev t = liftBase $ applyWithRef (fromTimer t) P.stddev 60 | variance t = liftBase $ applyWithRef (fromTimer t) P.variance 61 | maxVal t = liftBase $ P.maxVal <$> readMutVar (fromTimer t) 62 | minVal t = liftBase $ P.minVal <$> readMutVar (fromTimer t) 63 | 64 | instance (MonadBase b m, PrimMonad b) => Rate b m (Timer b) where 65 | oneMinuteRate t = liftBase $ do 66 | ts <- timerGetTime t 67 | updateAndApplyToRef (fromTimer t) (P.tickIfNecessary ts) P.oneMinuteRate 68 | fiveMinuteRate t = liftBase $ do 69 | ts <- timerGetTime t 70 | updateAndApplyToRef (fromTimer t) (P.tickIfNecessary ts) P.fiveMinuteRate 71 | fifteenMinuteRate t = liftBase $ do 72 | ts <- timerGetTime t 73 | updateAndApplyToRef (fromTimer t) (P.tickIfNecessary ts) P.fifteenMinuteRate 74 | meanRate t = liftBase $ do 75 | ts <- timerGetTime t 76 | applyWithRef (fromTimer t) (P.meanRate ts) 77 | 78 | instance (MonadBase b m, PrimMonad b) => TakeSnapshot b m (Timer b) where 79 | snapshot t = liftBase $ applyWithRef (fromTimer t) P.snapshot 80 | 81 | -- | Create a timer using a custom function for retrieving the current time. 82 | -- 83 | -- This is mostly exposed for testing purposes: prefer using "timer" if possible. 84 | mkTimer :: (MonadBase b m, PrimMonad b) => b NominalDiffTime -> Seed -> m (Timer b) 85 | mkTimer mt s = liftBase $ do 86 | t <- mt 87 | let ewmaMeter = M.meterData 5 E.movingAverage t 88 | let histogram = H.histogram $ R.reservoir 0.015 1028 t s 89 | v <- newMutVar $ P.Timer ewmaMeter histogram 90 | return $ Timer v mt 91 | 92 | -- | Create a standard "Timer" with an 93 | -- exponentially weighted moving average 94 | -- and an exponentially decaying histogram 95 | timer :: MonadBase IO m => m (Timer IO) 96 | timer = liftBase $ do 97 | s <- withSystemRandom (asGenIO $ save) 98 | mkTimer getPOSIXTime s 99 | 100 | -- | Execute an action and record statistics about the 101 | -- duration of the event and the rate of event occurrence. 102 | time :: MonadBase IO m => Timer IO -> m a -> m a 103 | time t m = do 104 | let gt = t ^. getTime 105 | ts <- liftBase gt 106 | r <- m 107 | tf <- liftBase gt 108 | update t $ realToFrac $ tf - ts 109 | return r 110 | 111 | -------------------------------------------------------------------------------- /src/Data/Metrics/Timer/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE FunctionalDependencies #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE TypeSynonymInstances #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | -- | A timer is essentially just a data type that combines 9 | -- a "Meter" and a "Histogram" to track both the rate at which 10 | -- events are triggered as well as timing statistics about the calls. 11 | -- 12 | -- This module exports the pure internals, relying on the stateful version 13 | -- to supply the pure timer with measurements. 14 | module Data.Metrics.Timer.Internal where 15 | import Control.Lens 16 | import Data.Time.Clock 17 | import qualified Data.Metrics.Histogram.Internal as H 18 | import qualified Data.Metrics.MovingAverage as A 19 | import qualified Data.Metrics.Meter.Internal as M 20 | import qualified Data.Metrics.Snapshot as S 21 | 22 | data Timer = Timer 23 | { timerMeter :: !M.Meter 24 | , timerHistogram :: !H.Histogram 25 | } 26 | 27 | makeFields ''Timer 28 | 29 | tickIfNecessary :: NominalDiffTime -> Timer -> Timer 30 | tickIfNecessary t = meter %~ M.tickIfNecessary t 31 | {-# INLINE tickIfNecessary #-} 32 | 33 | snapshot :: Timer -> S.Snapshot 34 | snapshot = H.snapshot . timerHistogram 35 | {-# INLINEABLE snapshot #-} 36 | 37 | oneMinuteRate :: Timer -> Double 38 | oneMinuteRate = A.rate . M.oneMinuteAverage . timerMeter 39 | {-# INLINEABLE oneMinuteRate #-} 40 | 41 | fiveMinuteRate :: Timer -> Double 42 | fiveMinuteRate = A.rate . M.fiveMinuteAverage . timerMeter 43 | {-# INLINEABLE fiveMinuteRate #-} 44 | 45 | fifteenMinuteRate :: Timer -> Double 46 | fifteenMinuteRate = A.rate . M.fifteenMinuteAverage . timerMeter 47 | {-# INLINEABLE fifteenMinuteRate #-} 48 | 49 | meanRate :: NominalDiffTime -> Timer -> Double 50 | meanRate t = M.meanRate t . timerMeter 51 | {-# INLINEABLE meanRate #-} 52 | 53 | count :: Timer -> Int 54 | count = H.count . view histogram 55 | {-# INLINEABLE count #-} 56 | 57 | clear :: NominalDiffTime -> Timer -> Timer 58 | clear t = (histogram %~ H.clear t) . (meter %~ M.clear t) 59 | {-# INLINEABLE clear #-} 60 | 61 | update :: NominalDiffTime -> Double -> Timer -> Timer 62 | update t x = (histogram %~ H.update x t) . (meter %~ M.mark t 1) 63 | {-# INLINEABLE update #-} 64 | 65 | mean :: Timer -> Double 66 | mean = H.mean . timerHistogram 67 | {-# INLINEABLE mean #-} 68 | 69 | stddev :: Timer -> Double 70 | stddev = H.stddev . timerHistogram 71 | {-# INLINEABLE stddev #-} 72 | 73 | variance :: Timer -> Double 74 | variance = H.variance . timerHistogram 75 | {-# INLINEABLE variance #-} 76 | 77 | maxVal :: Timer -> Double 78 | maxVal = H.maxVal . timerHistogram 79 | {-# INLINEABLE maxVal #-} 80 | 81 | minVal :: Timer -> Double 82 | minVal = H.minVal . timerHistogram 83 | {-# INLINEABLE minVal #-} 84 | 85 | -------------------------------------------------------------------------------- /src/Data/Metrics/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FunctionalDependencies #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE KindSignatures #-} 4 | -- | The main accessors for common stateful metric implementation data. 5 | module Data.Metrics.Types where 6 | import Control.Concurrent.MVar 7 | import Control.Monad.Primitive 8 | import Data.Functor.Identity 9 | import Data.HashMap.Strict (HashMap) 10 | import Data.Metrics.Internal 11 | import Data.Metrics.Snapshot 12 | import Data.Primitive.MutVar 13 | import Data.Text (Text) 14 | import Data.Vector.Unboxed (Vector) 15 | 16 | -- | Histogram moving averages are tracked (by default) on minute scale. 17 | type Minutes = Int 18 | 19 | -- | Get the current count for the given metric. 20 | class Count (b :: * -> *) m a | m -> b, a -> b where 21 | -- | retrieve a count 22 | count :: a -> m Int 23 | 24 | -- | Provides statistics from a histogram that tracks the standard moving average rates. 25 | class Rate (b :: * -> *) m a | m -> b, a -> b where 26 | -- | Get the average rate of occurrence for some sort of event for the past minute. 27 | oneMinuteRate :: a -> m Double 28 | -- | Get the average rate of occurrence for some sort of event for the past five minutes. 29 | fiveMinuteRate :: a -> m Double 30 | -- | Get the average rate of occurrence for some sort of event for the past fifteen minutes. 31 | fifteenMinuteRate :: a -> m Double 32 | -- | Get the mean rate of occurrence for some sort of event for the entirety of the time that 'a' has existed. 33 | meanRate :: a -> m Double 34 | 35 | -- | Gets the current value from a simple metric (i.e. a "Counter" or a "Gauge") 36 | class Value (b :: * -> *) m a v | m -> b, a -> b v where 37 | value :: a -> m v 38 | 39 | -- | Update a metric by performing wholesale replacement of a value. 40 | class Set (b :: * -> *) m a v | m -> b, a -> b v where 41 | -- | Replace the current value of a simple metric (i.e. a "Counter" or a "Gauge") 42 | set :: a -> v -> m () 43 | 44 | -- | Provides a way to reset metrics. This might be useful in a development environment 45 | -- or to periodically get a clean state for long-running processes. 46 | class Clear (b :: * -> *) m a | m -> b, a -> b where 47 | -- | Reset the metric to an 'empty' state. In practice, this should be 48 | -- equivalent to creating a new metric of the same type in-place. 49 | clear :: a -> m () 50 | 51 | -- | Provides the main interface for retrieving statistics tabulated by a histogram. 52 | class Statistics (b :: * -> *) m a | m -> b, a -> b where 53 | -- | Gets the highest value encountered thus far. 54 | maxVal :: a -> m Double 55 | -- | Gets the lowest value encountered thus far. 56 | minVal :: a -> m Double 57 | -- | Gets the current average value. This may have slightly different meanings 58 | -- depending on the type of "MovingAverage" used. 59 | mean :: a -> m Double 60 | -- | Gets the standard deviation of all values encountered this var. 61 | stddev :: a -> m Double 62 | -- | Gets the variance of all values encountered this var. 63 | variance :: a -> m Double 64 | 65 | -- | Update statistics tracked by a metric with a new sample. 66 | class Update (b :: * -> *) m a v | m -> b, a -> b v where 67 | -- | Feed a metric another value. 68 | update :: a -> v -> m () 69 | 70 | -- | Take a snapshot (a sorted vector) of samples used for calculating quantile data. 71 | class TakeSnapshot (b :: * -> *) m a | m -> b, a -> b where 72 | -- | Get a sample of the values currently in a histogram or type that contains a histogram. 73 | snapshot :: a -> m Snapshot 74 | 75 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: nightly-2017-07-31 2 | flags: {} 3 | packages: 4 | - '.' 5 | -------------------------------------------------------------------------------- /tests/CounterTest.hs: -------------------------------------------------------------------------------- 1 | module CounterTest where 2 | import Control.Concurrent.Async 3 | import Control.Monad 4 | import Data.Metrics.Counter 5 | import Data.Metrics.Types 6 | import Test.QuickCheck 7 | import Test.QuickCheck.Monadic 8 | 9 | counterTests :: [Property] 10 | counterTests = 11 | [ testIncrement 12 | , testIncrement' 13 | , testDecrement 14 | , testDecrement' 15 | , testConcurrent 16 | ] 17 | 18 | smallCount :: Gen Int 19 | smallCount = choose (0, 10000) 20 | 21 | withCounter :: (Counter IO -> IO a) -> IO a 22 | withCounter f = counter >>= f 23 | 24 | testIncrement :: Property 25 | testIncrement = label "single increment" $ monadicIO $ do 26 | x <- pick smallCount 27 | x' <- run $ do 28 | c <- counter 29 | replicateM_ x $ increment c 30 | count c 31 | assert (x == x') 32 | 33 | testIncrement' :: Property 34 | testIncrement' = label "higher increment" $ monadicIO $ do 35 | x <- pick smallCount 36 | x' <- run $ do 37 | c <- counter 38 | increment' c x 39 | count c 40 | assert $ x == x' 41 | 42 | testDecrement :: Property 43 | testDecrement = label "single decrement" $ monadicIO $ do 44 | x <- pick smallCount 45 | x' <- run $ do 46 | c <- counter 47 | replicateM_ x $ decrement c 48 | count c 49 | assert $ negate x == x' 50 | 51 | testDecrement' :: Property 52 | testDecrement' = label "higher decrement" $ monadicIO $ do 53 | x <- pick smallCount 54 | x' <- run $ do 55 | c <- counter 56 | decrement' c x 57 | count c 58 | assert $ negate x == x' 59 | 60 | testConcurrent :: Property 61 | testConcurrent = label "concurrently increment" $ monadicIO $ do 62 | x <- pick smallCount 63 | y <- pick (choose (0, 40) :: Gen Int) 64 | r <- run $ do 65 | c <- counter 66 | asyncs <- sequence $ take x $ repeat $ async $ replicateM_ y $ increment c 67 | mapM_ wait asyncs 68 | count c 69 | assert $ r == x * y 70 | 71 | -------------------------------------------------------------------------------- /tests/EDR.hs: -------------------------------------------------------------------------------- 1 | module EDR where 2 | import Control.Monad.ST 3 | import Data.Metrics.Reservoir 4 | import Data.Metrics.Reservoir.ExponentiallyDecaying (reservoir) 5 | import System.Random.MWC 6 | import Test.QuickCheck 7 | 8 | edrTests = [reservoirSizeIsLimited] 9 | 10 | seed = runST (create >>= save) 11 | testReservoir = testReservoir' 1028 12 | testReservoir' size = reservoir 0.015 size 0 seed 13 | 14 | reservoirSizeIsLimited :: Property 15 | reservoirSizeIsLimited = forAll (choose (1, 5000)) $ \x -> 16 | forAll (choose (0, x * 2)) $ \y -> 17 | size ((iterate (update 1 1) $ testReservoir' x) !! y) <= x 18 | -------------------------------------------------------------------------------- /tests/EWMA.hs: -------------------------------------------------------------------------------- 1 | module EWMA where 2 | import Data.Metrics.Internal 3 | import Data.Metrics.MovingAverage.ExponentiallyWeighted 4 | import Test.QuickCheck 5 | 6 | ewmaTests = 7 | [ 8 | {- property ticksDecreaseRateToZero 9 | , property ticksUpdateRate 10 | , constantRates 11 | , clearResetsRate 12 | -} 13 | ] 14 | 15 | smallNumbers = choose (1, 10000) 16 | 17 | ticksDecreaseRateToZero :: NonZero Double -> Property 18 | ticksDecreaseRateToZero (NonZero x) = label "ticks decay rate towards 0" $ forAll smallNumbers $ \tc -> 19 | abs (rate (run !! tc)) < abs x 20 | where 21 | run = iterate tick $ update x $ empty 5 1 22 | 23 | deltaEq :: Double -> Double -> Double -> Bool 24 | deltaEq range x y = abs (x - y) <= range 25 | 26 | ticksUpdateRate :: NonZero Double -> Property 27 | ticksUpdateRate (NonZero x) = label "updating rate and ticking once returns current rate" $ deltaEq 0.005 (rate run) x 28 | where 29 | run = tick $ update x $ empty 5 1 30 | 31 | constantRates :: Property 32 | constantRates = label "constant rates" $ \(NonZero x) -> forAll smallNumbers $ \t -> 33 | deltaEq 0.005 x $ rate (iterate (tick . update x) (empty 5 1) !! t) 34 | 35 | clearResetsRate :: Property 36 | clearResetsRate = label "reset rate" $ property (clearedRate == 0) 37 | where 38 | clearedRate = rate $ clear $ updatedRate 39 | updatedRate = tick $ update 10 $ empty 5 1 40 | -------------------------------------------------------------------------------- /tests/GaugeTest.hs: -------------------------------------------------------------------------------- 1 | module GaugeTest where 2 | import Data.Metrics.Gauge 3 | import Data.Metrics.Types 4 | import Test.QuickCheck 5 | import Test.QuickCheck.Monadic 6 | 7 | gaugeTests :: [Property] 8 | gaugeTests = [ testValue {-- , testSet, testRatio --} ] 9 | 10 | testValue :: Property 11 | testValue = label "test retrieving gauge value" $ monadicIO $ do 12 | x <- pick arbitrary 13 | x' <- run $ do 14 | g <- gauge $ return x 15 | value g 16 | assert $ x == x' 17 | 18 | testSet :: Property 19 | testSet = label "test overwriting gauge action" $ monadicIO $ do 20 | x <- pick arbitrary 21 | y <- pick arbitrary 22 | z <- run $ do 23 | g <- gauge $ return x 24 | set g $ return y 25 | value g 26 | assert $ y == z 27 | 28 | testRatio :: Property 29 | testRatio = label "test creating a ratio gauge" $ monadicIO $ do 30 | x <- pick arbitrary 31 | (NonZero y) <- pick arbitrary 32 | z <- run $ do 33 | g <- gauge $ ratio (return x) (return y) 34 | value g 35 | assert $ z == (x / y) 36 | -------------------------------------------------------------------------------- /tests/HistogramTest.hs: -------------------------------------------------------------------------------- 1 | module HistogramTest where 2 | import Control.Concurrent.Async 3 | import Control.Monad 4 | import Data.Metrics.Histogram 5 | import Data.Metrics.Snapshot 6 | import System.Random.MWC 7 | import Test.HUnit 8 | 9 | histogramTests :: [Test] 10 | histogramTests = 11 | [ testUniformSampleMin 12 | , testUniformSampleMax 13 | , testUniformSampleMean 14 | , testUniformSampleMeanThreaded 15 | , testUniformSample2000 16 | -- , testUniformSample2000Threaded 17 | , testUniformSampleSnapshot 18 | , testUniformSampleSnapshotThreaded 19 | , testExponentialSampleMin 20 | , testExponentialSampleMax 21 | , testExponentialSampleMean 22 | , testExponentialSampleMeanThreaded 23 | , testExponentialSample2000 24 | --, testExponentialSample2000Threaded 25 | , testExponentialSampleSnapshot 26 | , testExponentialSampleSnapshotThreaded 27 | -- , testExponentialSampleLongIdle 28 | ] 29 | 30 | 31 | withUniform :: (Histogram IO -> IO a) -> IO a 32 | withUniform f = do 33 | seed <- withSystemRandom (asGenIO save) 34 | h <- uniformHistogram seed 35 | f h 36 | 37 | withExponential :: (Histogram IO -> IO a) -> IO a 38 | withExponential f = do 39 | -- seed <- withSystemRandom (asGenIO save) 40 | -- t <- epochTime 41 | h <- exponentiallyDecayingHistogram -- t seed 42 | f h 43 | 44 | uniformTest :: Assertable a => String -> (Histogram IO -> IO a) -> Test 45 | uniformTest d f = d ~: test $ assert $ withUniform f 46 | 47 | exponentialTest :: Assertable a => String -> (Histogram IO -> IO a) -> Test 48 | exponentialTest d f = d ~: test $ assert $ withExponential f 49 | 50 | testUniformSampleMin :: Test 51 | testUniformSampleMin = uniformTest "uniform min value" $ \h -> do 52 | update h 5 53 | update h 10 54 | x <- minVal h 55 | assertEqual "min" 5 x 56 | 57 | testUniformSampleMax :: Test 58 | testUniformSampleMax = uniformTest "uniform max value" $ \h -> do 59 | update h 5 60 | update h 10 61 | x <- maxVal h 62 | assertEqual "max" 10 x 63 | 64 | testUniformSampleMean :: Test 65 | testUniformSampleMean = uniformTest "uniform mean value" $ \h -> do 66 | update h 5 67 | update h 10 68 | x <- mean h 69 | assertEqual "mean" 7.5 x 70 | 71 | testUniformSampleMeanThreaded :: Test 72 | testUniformSampleMeanThreaded = uniformTest "async uniform mean value" $ \h -> do 73 | let task = update h 5 >> update h 10 74 | asyncs <- replicateM 10 (async task) 75 | mapM_ wait asyncs 76 | x <- mean h 77 | assert $ x == 7.5 78 | 79 | testUniformSample2000 :: Test 80 | testUniformSample2000 = uniformTest "uniform sample 2000" $ \h -> do 81 | mapM_ (update h) [0..1999] 82 | x <- maxVal h 83 | assert $ x == 1999 84 | 85 | --testUniformSample2000Threaded :: Test 86 | --testUniformSample2000Threaded ="" ~: test $ do 87 | -- x <- with 88 | 89 | testUniformSampleSnapshot :: Test 90 | testUniformSampleSnapshot = uniformTest "uniform snapshot" $ \h -> do 91 | mapM_ (update h) [0..99] 92 | s <- snapshot h 93 | assert $ median s == 49.5 94 | 95 | testUniformSampleSnapshotThreaded :: Test 96 | testUniformSampleSnapshotThreaded = uniformTest "async uniform snapshot" $ \h -> do 97 | let task = mapM_ (update h) [0..99] 98 | asyncs <- replicateM 10 (async task) 99 | mapM_ wait asyncs 100 | s <- snapshot h 101 | assertEqual "median" 49.5 $ median s 102 | 103 | testExponentialSampleMin :: Test 104 | testExponentialSampleMin = exponentialTest "minVal" $ \h -> do 105 | update h 5 106 | update h 10 107 | x <- minVal h 108 | assertEqual "min" 5 x 109 | 110 | testExponentialSampleMax :: Test 111 | testExponentialSampleMax = exponentialTest "maxVal" $ \h -> do 112 | update h 5 113 | update h 10 114 | x <- maxVal h 115 | assertEqual "max" 10 x 116 | 117 | testExponentialSampleMean :: Test 118 | testExponentialSampleMean = exponentialTest "mean" $ \h -> do 119 | update h 5 120 | update h 10 121 | x <- mean h 122 | assertEqual "mean" 7.5 x 123 | 124 | testExponentialSampleMeanThreaded :: Test 125 | testExponentialSampleMeanThreaded = exponentialTest "mean threaded" $ \h -> do 126 | let task = update h 5 >> update h 10 127 | asyncs <- replicateM 10 (async task) 128 | mapM_ wait asyncs 129 | x <- mean h 130 | assertEqual "mean" 7.5 x 131 | 132 | testExponentialSample2000 :: Test 133 | testExponentialSample2000 = exponentialTest "sample 2000" $ \h -> do 134 | mapM_ (update h) [0..1999] 135 | x <- maxVal h 136 | assertEqual "max" 1999 x 137 | 138 | --testExponentialSample2000Threaded :: Test 139 | --testExponentialSample2000Threaded = exponentialTest "async sample 2000" $ \h -> do 140 | -- x <- with 141 | 142 | testExponentialSampleSnapshot :: Test 143 | testExponentialSampleSnapshot = exponentialTest "snapshot" $ \h -> do 144 | mapM_ (update h) [0..99] 145 | s <- snapshot h 146 | assertEqual "median" 49.5 $ median s 147 | 148 | testExponentialSampleSnapshotThreaded :: Test 149 | testExponentialSampleSnapshotThreaded = exponentialTest "async snapshot" $ \h -> do 150 | let task = mapM_ (update h) [0..99] 151 | asyncs <- replicateM 10 (async task) 152 | mapM_ wait asyncs 153 | s <- snapshot h 154 | assertEqual "median" 49.5 $ median s 155 | 156 | --testExponentialSampleLongIdle :: Test 157 | --testExponentialSampleLongIdle ="" ~: test $ do 158 | -- x <- with 159 | -------------------------------------------------------------------------------- /tests/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | import Control.Monad 3 | import CounterTest 4 | import GaugeTest 5 | import EDR 6 | import EWMA 7 | -- import HistogramTest 8 | import Test.QuickCheck 9 | --import MeterTest 10 | --import RegistryTest 11 | --import TimerTest 12 | 13 | main = mapM_ quickCheck $ 14 | counterTests ++ 15 | gaugeTests ++ 16 | ewmaTests ++ 17 | edrTests 18 | -------------------------------------------------------------------------------- /tests/MeterTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Rank2Types #-} 2 | module MeterTest where 3 | import Control.Lens 4 | import Control.Monad 5 | import Control.Monad.Primitive 6 | import Control.Monad.ST 7 | import Data.Metrics.Internal 8 | import Data.Metrics.Meter 9 | import Data.Metrics.Meter.Internal (lastTick) 10 | import Data.Metrics.Types 11 | import Data.Primitive.MutVar 12 | import Data.STRef 13 | import Test.QuickCheck 14 | import Test.QuickCheck.Monadic 15 | import System.Posix.Types 16 | 17 | 18 | smallCount :: Gen Int 19 | smallCount = choose (0, 10000) 20 | 21 | 22 | increment1s :: Num a => STRef s a -> ST s a 23 | increment1s r = do 24 | modifySTRef r (+ 1) 25 | readSTRef r 26 | 27 | 28 | run1sMeter :: (forall s. Meter (ST s) -> ST s a) -> a 29 | run1sMeter f = runST $ do 30 | r <- newSTRef 0 31 | m <- mkMeter $ increment1s r 32 | f m 33 | 34 | 35 | meterCountTest :: Property 36 | meterCountTest = label "mark increments count" $ monadicST $ do 37 | x <- pick smallCount 38 | let c = run1sMeter $ \m -> do 39 | replicateM_ x (mark m) 40 | count m 41 | assert $ x == c 42 | -- testMeter 43 | -- testMeterThreaded 44 | -- testOneMinuteRate 45 | 46 | 47 | testTicks = runST $ do 48 | r <- newSTRef 0 49 | m <- mkMeter $ increment1s r 50 | mark m 51 | mark m 52 | mark m 53 | mark m 54 | mark m 55 | md <- readMutVar (fromMeter m) 56 | x <- readSTRef r 57 | return $ (md ^. lastTick, x) 58 | 59 | 60 | -------------------------------------------------------------------------------- /tests/RegistryTest.hs: -------------------------------------------------------------------------------- 1 | module RegistryTest where 2 | import Test.QuickCheck 3 | -------------------------------------------------------------------------------- /tests/TimerTest.hs: -------------------------------------------------------------------------------- 1 | module TimerTest where 2 | import Test.QuickCheck 3 | 4 | 5 | --------------------------------------------------------------------------------