packages feed

metrics (empty) → 0.1.0.0

raw patch · 24 files changed

+1791/−0 lines, 24 filesdep +QuickCheckdep +ansi-terminaldep +asyncsetup-changed

Dependencies added: QuickCheck, ansi-terminal, async, base, containers, lens, metrics, mtl, mwc-random, primitive, text, time, unix, unordered-containers, vector, vector-algorithms

Files

+ LICENSE view
@@ -0,0 +1,20 @@+The MIT License (MIT)++Copyright (c) 2013 SaneTracker++Permission is hereby granted, free of charge, to any person obtaining a copy of+this software and associated documentation files (the "Software"), to deal in+the Software without restriction, including without limitation the rights to+use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of+the Software, and to permit persons to whom the Software is furnished to do so,+subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS+FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR+COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER+IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ metrics.cabal view
@@ -0,0 +1,86 @@+-- Initial submarine-metrics.cabal generated by cabal init.  For further +-- documentation, see http://haskell.org/cabal/users-guide/++name:                metrics+version:             0.1.0.0+synopsis:            High-performance application metric tracking+description:+  A port of Coda Hale's excellent metrics library for the JVM+  .+  <https://github.com/codahale/metrics>+  .+  For motivation about why you might want to track application metrics, check Coda\'s talk:+  .+  <http://www.youtube.com/watch?v=czes-oa0yik>+  .+  Interesting portions of this package's documentation were also appropriated from the metrics library's documentation:+  .+  <http://metrics.codahale.com>+license:             MIT+license-file:        LICENSE+author:              Ian Duncan+maintainer:          ian@iankduncan.com+-- copyright:           +category:            Data+build-type:          Simple+-- extra-source-files:  +cabal-version:       >=1.10+source-repository    head+  type:                git+  location:            http://github.com/sanetracker/metrics++library+  exposed-modules:     Data.HealthCheck+                       Data.Metrics,+                       Data.Metrics.Counter,+                       Data.Metrics.Gauge,+                       Data.Metrics.Histogram,+                       Data.Metrics.Histogram.Internal,+                       Data.Metrics.Internal,+                       Data.Metrics.MovingAverage,+                       Data.Metrics.MovingAverage.ExponentiallyWeighted,+                       Data.Metrics.Meter,+                       Data.Metrics.Meter.Internal,+                       Data.Metrics.Timer,+                       Data.Metrics.Timer.Internal,+                       Data.Metrics.Reporter.StdOut,+                       Data.Metrics.Reservoir,+                       Data.Metrics.Reservoir.ExponentiallyDecaying,+                       Data.Metrics.Reservoir.Uniform,+                       Data.Metrics.Snapshot,+                       Data.Metrics.Registry,+                       Data.Metrics.Types++  -- other-modules:       +  -- other-extensions:    +  build-depends:       base >=4.6 && <4.7,+                       unordered-containers,+                       text,+                       mtl,+                       vector,+                       primitive,+                       mwc-random,+                       unix,+                       vector-algorithms,+                       containers,+                       time,+                       lens >= 3.10 && < 4,+                       ansi-terminal >= 0.6 && < 0.7+  hs-source-dirs:      src+  default-language:    Haskell2010++test-suite             tests+  main-is:             Main.hs+  -- other-modules:       CounterTest, ExponentiallyDecayingReservoirTest, GaugeTest, HistogramTest, MeterTest, RegistryTest, TimerTest+  hs-source-dirs:      tests+  type:                exitcode-stdio-1.0+  build-depends:       base >= 4.6 && <5,+                       metrics,+                       async,+                       mwc-random >= 0.13,+                       unix,+                       QuickCheck,+                       primitive,+                       lens >= 3.10 && < 4+  default-language:    Haskell2010+  ghc-options:         -rtsopts -threaded -with-rtsopts=-N
+ src/Data/HealthCheck.hs view
@@ -0,0 +1,59 @@+-- |+-- Module      : Data.HealthCheck+-- Copyright   : (c) Ian Duncan 2013+-- Stability   : experimental+-- Portability : non-portable+--+-- A simple interface through which simple status dashboards can be built.+--+-- > import Data.HealthCheck+-- > import Data.Metrics.Reporter.StdOut+-- > +-- > healthCheck1 :: HealthCheck+-- > healthCheck1 = healthCheck "benign_warm_fuzzy_thing" $+-- >   return $ StatusReport Good Nothing+-- > +-- > healthCheck2 :: HealthCheck+-- > healthCheck2 = healthCheck "nuclear_missile_launcher" $+-- >   return $ StatusReport Ugly $ Just "out of missiles"+-- > +-- > main :: IO ()+-- > main = printHealthChecks [ healthCheck1, healthCheck2 ]+--+module Data.HealthCheck (+  HealthCheck(..),+  HealthChecks,+  healthCheck,+  Status(..),+  StatusReport(..)+) where+import Data.Text (Text)++-- | Clean up type signatures for bundling sets of health checks for reporting+type HealthChecks = [HealthCheck]++-- | A simple discrete health reporter+data HealthCheck = HealthCheck+  { healthCheckStatusReport :: IO StatusReport -- ^ An action which determines the current status of the health check+  , healthCheckName :: Text -- ^ A unique identifier for the health check+  }++-- | Provides a simple status reporting mechanism for checking application health at a glance.+data Status+  = Good -- ^ Everything appears to be going well.+  | Bad -- ^ Something is broken.+  | Ugly -- ^ There is some sort of non-critical issue that deserves attention.+  | Unknown +    -- ^ There is no information, either good or bad, at the moment.+    -- An example of this might be something like a loss of network connectivity to a non-crucial service.+  deriving (Read, Show, Eq, Ord)++-- | A report on the current status of a subsystem.+data StatusReport = StatusReport+  { status :: Status -- ^ Current status+  , statusMessage :: Maybe Text -- ^ An optional message to display about the current status.+  } deriving (Show)++-- | Create a health check.+healthCheck :: Text -> IO StatusReport -> HealthCheck+healthCheck = flip HealthCheck
+ src/Data/Metrics.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE OverloadedStrings #-}+-- |+-- Module      : Data.Metrics+-- Copyright   : (c) Ian Duncan 2013+-- Stability   : experimental+-- Portability : non-portable+--+-- A library for tracking arbitrary metrics over time.+-- The library largely provides pure and stateful versions of+-- the same set of functionality for common metric types.+--+module Data.Metrics (+  module Data.HealthCheck,+  module Data.Metrics.Counter,+  module Data.Metrics.Gauge,+  module Data.Metrics.Histogram,+  module Data.Metrics.Meter,+  module Data.Metrics.Registry,+  module Data.Metrics.Timer,+  module Data.Metrics.Types+) where+import Data.HealthCheck+import Data.Metrics.Counter+import Data.Metrics.Gauge+import Data.Metrics.Histogram+import Data.Metrics.Meter+import Data.Metrics.Registry+import Data.Metrics.Timer+import Data.Metrics.Types++--newMetricRegistry :: IO (MetricRegistry IO)+--newMetricRegistry = fmap MetricRegistry $ newMVar H.empty++{-+getOrInit :: (Typeable a, MetricOutput a) => MetricRegistry -> Text -> a -> IO (Maybe (IORef a))+getOrInit r name conv defaultValue = do+  hm <- takeMVar $ metrics r+  case H.lookup name hm of+    Nothing -> do+      ref <- newIORef defaultValue+      let getRep = readIORef ref >>= conv+      putMVar (metrics r) $! H.insert name (getRep, toDyn ref) hm+      return $! Just ref+    Just (_, ref) -> do+      putMVar (metrics r) hm+      return $! fromDynamic ref+-}++{-+counter :: MonadIO m => MetricRegistry -> Text -> m (Maybe Counter)+counter registry conv name = do+  mref <- liftIO $ getOrInit registry name (return . conv) 0+  case mref of+    Nothing -> return Nothing+    Just ref -> return $! Just $! Counter ref++gauge :: Typeable a => MetricRegistry -> Text -> IO a -> IO (Maybe (Gauge a))+gauge registry conv name g = do+  mref <- liftIO $ getOrInit registry name (fmap conv) g+  case mref of+    Nothing -> return Nothing+    Just ref -> return $! Just $! Gauge ref++cache :: DiffTime -> Gauge a -> m ()+DerivativeGauge+ExponentiallyWeightedMovingAverage+ExponentiallyDecayingReservoir++data Ratio = Ratio+  { numerator :: IORef Double+  , denominator :: IORef Double+  }++newtype RatioGauge = Gauge Ratio+Reservoir+SlidingTimeWindowReservoir++cachedGauge+derivedGauge+-}++--test = do+--  r <- newMetricRegistry+--  (Just c) <- register r "wombats.sighted" counter+--  (Just c2) <- register r "wombats.sighted" counter+--  increment c+--  value c >>= print+--  value c2 >>= print+
+ src/Data/Metrics/Counter.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}+-- |+-- Module      : Data.Metrics.Counter+-- Copyright   : (c) Ian Duncan 2013+-- Stability   : experimental+-- Portability : non-portable+--+-- An incrementing and decrementing counter metric+--+-- > import Data.Metrics.Counter+-- >+-- > main :: IO ()+-- > main = do+-- >   c <- counter+-- >   increment c+-- >   x <- value c+-- >   print $ x == 1+--+module Data.Metrics.Counter (+  Counter,+  counter,+  increment,+  increment',+  decrement,+  decrement',+  module Data.Metrics.Types+) where+import Control.Monad.Primitive+import qualified Data.HashMap.Strict as H+import Data.Metrics.Internal+import Data.Metrics.Types+import Data.Primitive.MutVar++-- | A basic atomic counter.+newtype Counter m = Counter { fromCounter :: MV m Int }++instance PrimMonad m => Count m (Counter m) where+  count (Counter ref) = readMutVar ref++instance PrimMonad m => Value m (Counter m) Int where+  value (Counter ref) = readMutVar ref++instance PrimMonad m => Set m (Counter m) Int where+  set (Counter ref) x = updateRef ref (const x)++instance PrimMonad m => Clear m (Counter m) where+  clear c = set c 0++-- | Create a new counter.+counter :: (Functor m, PrimMonad m) => m (Counter m)+counter = fmap Counter $ newMutVar 0++-- | Bump up a counter by 1.+increment :: PrimMonad m => Counter m -> m ()+increment = flip increment' 1++-- | Add an arbitrary amount to a counter.+increment' :: PrimMonad m => Counter m -> Int -> m ()+increment' (Counter ref) x = updateRef ref (+ x)++-- | Decrease the value of a counter by 1.+decrement :: PrimMonad m => Counter m -> m ()+decrement = flip decrement' 1++-- | Subtract an arbitrary amount from a counter.+decrement' :: PrimMonad m => Counter m -> Int -> m ()+decrement' (Counter ref) x = updateRef ref (subtract x)
+ src/Data/Metrics/Gauge.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+-- | A module representing a "Gauge", which is simply an action that returns the instantaneous measure of a value for charting.+--+-- The action that provides the gauge's value may be replaced using "set", or read using "value".+--+-- @+-- gaugeExample = do+--   g <- gauge $ return 1+--   x <- value g+--   set g $ return 2+--   y <- value g+--   return (x == 1 && y == 2)+-- @+module Data.Metrics.Gauge (+  Gauge,+  gauge,+  ratio,+  module Data.Metrics.Types+) where+import Control.Applicative+import Control.Monad+import Control.Monad.Primitive+import qualified Data.HashMap.Strict as H+import Data.Metrics.Internal+import Data.Metrics.Types+import Data.Primitive.MutVar++-- | An instantaneous measure of a value.+newtype Gauge m = Gauge { fromGauge :: MV m (m Double) }++-- | Create a new gauge from the given action.+gauge :: PrimMonad m => m Double -> m (Gauge m)+gauge m = do+  r <- newMutVar m+  return $ Gauge r++instance (PrimMonad m) => Value m (Gauge m) Double where+  value (Gauge r) = join $ readMutVar r++instance (PrimMonad m) => Set m (Gauge m) (m Double) where+  set (Gauge r) = updateRef r . const++-- | Compose multiple actions to create a ratio. Useful for graphing percentage information, e. g.+--+-- @+-- connectionUtilizationRate :: IO (Gauge IO)+-- connectionUtilizationRate = gauge $ ratio openConnectionCount $ return connectionPoolSize+-- @+ratio :: Applicative f => f Double -> f Double -> f Double+ratio x y = (/) <$> x <*> y
+ src/Data/Metrics/Histogram.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+-- | 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.+--+-- 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.+--+-- 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.+module Data.Metrics.Histogram (+  Histogram,+  histogram,+  exponentiallyDecayingHistogram,+  uniformHistogram,+  module Data.Metrics.Types+) where+import Control.Monad.Primitive+import qualified Data.Metrics.Histogram.Internal as P+import Data.Metrics.Internal+import Data.Metrics.Types+import Data.Metrics.Reservoir (Reservoir)+import Data.Metrics.Reservoir.Uniform (unsafeReservoir)+import Data.Metrics.Reservoir.ExponentiallyDecaying (reservoir)+import Data.Primitive.MutVar+import Data.Time.Clock+import Data.Time.Clock.POSIX+import System.Random.MWC++-- | A measure of the distribution of values in a stream of data.+data Histogram m = Histogram+  { fromHistogram :: MV m P.Histogram+  , histogramGetSeconds :: m NominalDiffTime+  }++instance PrimMonad m => Clear m (Histogram m) where+  clear h = do+    t <- histogramGetSeconds h+    updateRef (fromHistogram h) $ P.clear t++instance PrimMonad m => Update m (Histogram m) Double where+  update h x = do+    t <- histogramGetSeconds h+    updateRef (fromHistogram h) $ P.update x t++instance PrimMonad m => Count m (Histogram m) where+  count h = readMutVar (fromHistogram h) >>= return . P.count++instance PrimMonad m => Statistics m (Histogram m) where+  mean h = applyWithRef (fromHistogram h) P.mean+  stddev h = applyWithRef (fromHistogram h) P.stddev+  variance h = applyWithRef (fromHistogram h) P.variance+  maxVal h = readMutVar (fromHistogram h) >>= return . P.maxVal+  minVal h = readMutVar (fromHistogram h) >>= return . P.minVal++instance PrimMonad m => TakeSnapshot m (Histogram m) where+  snapshot h = applyWithRef (fromHistogram h) P.snapshot++-- | Create a histogram using a custom time data supplier function and a custom reservoir.+histogram :: PrimMonad m => m NominalDiffTime -> Reservoir -> m (Histogram m)+histogram t r = do+  v <- newMutVar $ P.histogram r+  return $ Histogram v t++-- | A histogram that gives all entries an equal likelihood of being evicted.+--+-- Probably not what you want for most time-series data.+uniformHistogram :: Seed -> IO (Histogram IO)+uniformHistogram s = histogram getPOSIXTime $ unsafeReservoir s 1028++-- | The recommended histogram type. It provides a fast histogram that+-- probabilistically evicts older entries using a weighting system. This+-- ensures that snapshots remain relatively fresh.+exponentiallyDecayingHistogram :: IO (Histogram IO)+exponentiallyDecayingHistogram = do+  t <- getPOSIXTime+  s <- createSystemRandom >>= save+  histogram getPOSIXTime $ reservoir 0.015 1028 t s++uniformSampler :: Seed -> P.Histogram+uniformSampler s = P.histogram (unsafeReservoir s 1028)++nan :: Double+nan = 0 / 0
+ src/Data/Metrics/Histogram/Internal.hs view
@@ -0,0 +1,125 @@+-- | The pure interface for histograms.+-- This module is typically not as useful as the stateful implementation+-- since reservoir updates require retrieving the current time.+module Data.Metrics.Histogram.Internal (+  Histogram,+  histogram,+  clear,+  update,+  mean,+  stddev,+  variance,+  minVal,+  maxVal,+  count,+  snapshot+) where+import Data.Time.Clock+import qualified Data.Metrics.Reservoir as R+import Data.Metrics.Snapshot (Snapshot)++-- | A pure histogram that maintains a bounded reservoir of samples and basic statistical data about the samples.+data Histogram = Histogram+  { _histogramReservoir :: !R.Reservoir+  , _histogramCount :: !Int+  , _histogramMinVal :: !Double+  , _histogramMaxVal :: !Double+  , _histogramSum :: !Double+  , _histogramVariance :: !(Double, Double)+  }++-- | Create a histogram using a custom reservoir.+histogram :: R.Reservoir -> Histogram+histogram r = Histogram r 0 nan nan 0 (0, 0)++nan :: Double+nan = 0 / 0++-- | Reset all statistics, in addition to the underlying reservoir.+clear :: NominalDiffTime -> Histogram -> Histogram+clear = go+  where+    go t s = s+      { _histogramReservoir = R.clear t $ _histogramReservoir s+      , _histogramCount = 0+      , _histogramMinVal = nan+      , _histogramMaxVal = nan+      , _histogramSum = 0+      , _histogramVariance = (-1, 0)+      }++-- | Update statistics and the reservoir with a new sample.+update :: Double -> NominalDiffTime -> Histogram -> Histogram+update = go+  where+    go v t s = s+      { _histogramReservoir = updatedReservoir+      , _histogramCount = updatedCount+      , _histogramMinVal = updateMin (_histogramMinVal s) v+      , _histogramMaxVal = updateMax (_histogramMaxVal s) v+      , _histogramSum = _histogramSum s + v+      , _histogramVariance = updateVariance updatedCount v $ _histogramVariance s+      }+      where +        updatedCount = succ $ _histogramCount s+        updatedReservoir = R.update v t $ _histogramReservoir s++updateMin :: Double -> Double -> Double+updateMin ox x = if isNaN ox || ox > x then x else ox++updateMax :: Double -> Double -> Double+updateMax ox x = if isNaN ox || ox < x then x else ox++-- | Get the average of all samples since the histogram was created.+mean :: Histogram -> Double+mean = go+  where+    go s = if _histogramCount s > 0+      then _histogramSum s / fromIntegral (_histogramCount s)+      else 0++-- | Get the standard deviation of all samples.+stddev :: Histogram -> Double+stddev = go+  where+    go s = if c > 0+      then (calculateVariance c $ snd $ _histogramVariance s) ** 0.5+      else 0+      where c = _histogramCount s++-- | Get the variance of all samples.+variance :: Histogram -> Double+variance = go+  where+    go s = if c <= 1+      then 0+      else calculateVariance c $ snd $ _histogramVariance s+      where c = _histogramCount s++-- | Get the minimum value of all samples.+minVal :: Histogram -> Double+minVal = _histogramMinVal++-- | Get the maximum value of all samples+maxVal :: Histogram -> Double+maxVal = _histogramMaxVal++-- | Get the number of samples that the histogram has been updated with.+count :: Histogram -> Int+count = _histogramCount++-- | Get a snapshot of the current reservoir's samples.+snapshot :: Histogram -> Snapshot+snapshot = R.snapshot . _histogramReservoir++calculateVariance :: Int -> Double -> Double+calculateVariance c v = if c <= 1 then 0 else v / (fromIntegral c - 1)++updateVariance :: Int -> Double -> (Double, Double) -> (Double, Double)+updateVariance _ c (-1, y) = (c, 0)+updateVariance count c (x, y) = (l, r)+  where+    c' = fromIntegral count+    diff = c - x+    l = x + diff / c'+    r = y + diff * (c - l)
+ src/Data/Metrics/Internal.hs view
@@ -0,0 +1,42 @@+-- | Internal helpers that provide strict atomic MutVar access.+--+-- These functions allow us to avoid the overhead of MVar as long+-- as we can factor the impure sections of code out in such a way+-- that the pure metric calculations can be executed without requiring+-- access to multiple MutVars at a time.+module Data.Metrics.Internal (+  updateRef,+  applyWithRef,+  updateAndApplyToRef,+  MV+) where+import Control.Monad.Primitive+import Data.Primitive.MutVar++-- | Perform a strict update on a MutVar. Pretty much identical to the strict variant of atomicModifyIORef.+updateRef :: PrimMonad m => MV m a -> (a -> a) -> m ()+updateRef r f = do+  b <- atomicModifyMutVar r (\x -> let (a, b) = (f x, ()) in (a, a `seq` b))+  b `seq` return b++-- | Strictly apply a function on a MutVar while blocking other access to it.+--+-- I really think this is probably not implemented correctly in terms of being excessively strict.+applyWithRef :: PrimMonad m => MV m a -> (a -> b) -> m b+applyWithRef r f = do+  b <- atomicModifyMutVar r (\x -> let app = f x in let (a, b) = (x, app) in (a, a `seq` b))+  b `seq` return b++-- | A function which combines the previous two, updating a value atomically+-- and then returning some value calculated with the update in a single step.+updateAndApplyToRef :: PrimMonad m => MV m a -> (a -> a) -> (a -> b) -> m b+updateAndApplyToRef r fa fb = do+  b <- atomicModifyMutVar r $ \x ->+    let appA = fa x in+    let appB = fb appA in+    let (a, b) = (appA, appB) in+    (a, a `seq` b)+  b `seq` return b++-- | MutVar (PrimState m) is a little verbose.+type MV m = MutVar (PrimState m)
+ src/Data/Metrics/Meter.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+-- | A meter measures the rate at which a set of events occur:+--+-- 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.+--+-- (Just like the Unix load averages visible in uptime or top.)+module Data.Metrics.Meter (+  Meter,+  meter,+  mark,+  mark',+  module Data.Metrics.Types+) where+import Control.Lens+import Control.Monad.Primitive+import Data.Primitive.MutVar+import Data.Time.Clock+import Data.Time.Clock.POSIX+import qualified Data.HashMap.Strict as H+import Data.Metrics.Internal+import qualified Data.Metrics.Meter.Internal as P+import qualified Data.Metrics.MovingAverage as A+import qualified Data.Metrics.MovingAverage.ExponentiallyWeighted as EWMA+import Data.Metrics.Types++-- | A measure of the /rate/ at which a set of events occurs.+data Meter m = Meter+  { fromMeter :: !(MV m P.Meter)+  , meterGetSeconds :: !(m NominalDiffTime)+  }++instance PrimMonad m => Rate m (Meter m) where+  oneMinuteRate m = do+    t <- meterGetSeconds m+    updateAndApplyToRef (fromMeter m) (P.tickIfNecessary t) (A.rate . P.oneMinuteAverage)+  fiveMinuteRate m = do+    t <- meterGetSeconds m+    updateAndApplyToRef (fromMeter m) (P.tickIfNecessary t) (A.rate . P.fiveMinuteAverage)+  fifteenMinuteRate m = do+    t <- meterGetSeconds m+    updateAndApplyToRef (fromMeter m) (P.tickIfNecessary t) (A.rate . P.fifteenMinuteAverage)+  meanRate m = do+    t <- meterGetSeconds m+    applyWithRef (fromMeter m) $ P.meanRate t++instance PrimMonad m => Count m (Meter m) where+  count m = readMutVar (fromMeter m) >>= return . view P.count++-- | Register multiple occurrences of an event.+mark' :: PrimMonad m => Meter m -> Int -> m ()+mark' m x = do+  t <- meterGetSeconds m+  updateRef (fromMeter m) (P.mark t x)++-- | Register a single occurrence of an event.+mark :: PrimMonad m => Meter m -> m ()+mark = flip mark' 1++-- | Create a new meter using an exponentially weighted moving average+meter :: IO (Meter IO)+meter = mkMeter getPOSIXTime++-- | Create a meter using a custom function for retrieving the current time.+--+-- This is mostly exposed for testing purposes: prefer using "meter" if possible.+mkMeter :: PrimMonad m => m NominalDiffTime -> m (Meter m)+mkMeter m = do+  t <- m+  v <- newMutVar $ ewmaMeter t+  return $! Meter v m++-- | Make a pure meter using an exponentially weighted moving average+ewmaMeter :: NominalDiffTime -- ^ The starting time of the meter.+  -> P.Meter+ewmaMeter = P.meterData (EWMA.movingAverage 0.5)+
+ src/Data/Metrics/Meter/Internal.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances #-}+module Data.Metrics.Meter.Internal (+  Meter,+  meterData,+  mark,+  clear,+  tick,+  meanRate,+  oneMinuteAverage,+  fiveMinuteAverage,+  fifteenMinuteAverage,+  tickIfNecessary,+  count+) where+import Control.Lens+import Control.Lens.TH+import Data.Time.Clock+import qualified Data.Metrics.MovingAverage as M++data Meter = Meter+  { _meterCount :: !Int+  , _meterOneMinuteRate :: !M.MovingAverage+  , _meterFiveMinuteRate :: !M.MovingAverage+  , _meterFifteenMinuteRate :: !M.MovingAverage+  , _meterStartTime :: !NominalDiffTime+  , _meterLastTick :: !NominalDiffTime+  }++makeFields ''Meter++meterData :: (Int -> M.MovingAverage) -> NominalDiffTime -> Meter+meterData f t = Meter+  { _meterCount = 0+  , _meterOneMinuteRate = f 1+  , _meterFiveMinuteRate = f 5+  , _meterFifteenMinuteRate = f 15+  , _meterStartTime = t+  , _meterLastTick = t+  }++-- TODO: make moving average prism++mark :: NominalDiffTime -> Int -> Meter -> Meter+mark t c m = ticked+  & count +~ c+  & oneMinuteRate %~ updateMeter +  & fiveMinuteRate %~ updateMeter+  & fifteenMinuteRate %~ updateMeter+  where+    updateMeter = M.update $ fromIntegral c+    ticked = tickIfNecessary t m++clear :: NominalDiffTime -> Meter -> Meter+clear t =+  (count .~ 0) .+  (startTime .~ t) .+  (lastTick .~ t) .+  (oneMinuteRate %~ M.clear) .+  (fiveMinuteRate %~ M.clear) .+  (fifteenMinuteRate %~ M.clear)++tick :: Meter -> Meter+tick = (oneMinuteRate %~ M.tick) . (fiveMinuteRate %~ M.tick) . (fifteenMinuteRate %~ M.tick)++tickIfNecessary :: NominalDiffTime -> Meter -> Meter+tickIfNecessary new d = if age >= 5+  then iterate tick (d { _meterLastTick = latest }) !! (truncate age `div` 5)+  else d+  where+    age = new - _meterLastTick d+    swapped = _meterLastTick d < new+    latest = Prelude.max (_meterLastTick d) new++meanRate :: NominalDiffTime -> Meter -> Double+meanRate t d = if c == 0+  then 0+  else fromIntegral c / fromIntegral elapsed+  where+    c = _meterCount d+    start = _meterStartTime d+    elapsed = fromEnum t - fromEnum start++oneMinuteAverage :: Meter -> M.MovingAverage+oneMinuteAverage = _meterOneMinuteRate++fiveMinuteAverage :: Meter -> M.MovingAverage+fiveMinuteAverage = _meterFiveMinuteRate++fifteenMinuteAverage :: Meter -> M.MovingAverage+fifteenMinuteAverage = _meterFifteenMinuteRate
+ src/Data/Metrics/MovingAverage.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE ExistentialQuantification #-}++-- | A pure moving average module. The interface is agnostic to the scale of time+-- that the average is tracking. It is up to the specific moving average module to+-- handle that functionality.+module Data.Metrics.MovingAverage where++-- | This type encapsulates the interface+-- of the different moving average implementations in such a way that they+-- can be reused without plumbing the types through the other components that+-- use moving averages. Most people won't ever need to use record fields of+-- this type.+data MovingAverage = forall s. MovingAverage+  { movingAverageClear :: !(s -> s)+  -- ^ clear the internal state of the moving average+  , movingAverageUpdate :: !(Double -> s -> s)+  -- ^ add a new sample to the moving average+  , movingAverageTick :: !(s -> s)+  -- ^ perform any modifications of the internal state associated with the passage of a predefined interval of time.+  , movingAverageRate :: !(s -> Double)+  -- ^ get the current rate of the moving average.+  , movingAverageState :: !s+  -- ^ the internal implementation state of the moving average+  }++-- | Reset a moving average back to a starting state.+clear :: MovingAverage -> MovingAverage+clear (MovingAverage c u t r s) = MovingAverage c u t r (c s)++-- | Get the current rate of the moving average.+rate :: MovingAverage -> Double+rate (MovingAverage _ _ _ r s) = r s++-- | Update the average based upon an interval specified by the+-- moving average implementation.+tick :: MovingAverage -> MovingAverage+tick (MovingAverage c u t r s) = MovingAverage c u t r (t s)++-- | Update the average with the specified value.+update :: Double -> MovingAverage -> MovingAverage+update x (MovingAverage c u t r s) = MovingAverage c u t r (u x s)
+ src/Data/Metrics/MovingAverage/ExponentiallyWeighted.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+-- | An exponentially-weighted moving average.+--+-- see /UNIX Load Average Part 1: How It Works/:+--+-- <http://www.teamquest.com/pdfs/whitepaper/ldavg1.pdf>+--+-- see /UNIX Load Average Part 2: Not Your Average Average/+--+-- <http://www.teamquest.com/pdfs/whitepaper/ldavg2.pdf>+-- +-- see Wikipedia's article on exponential moving averages:+--+-- <http://en.wikipedia.org/wiki/Moving_average#Exponential_moving_average>+module Data.Metrics.MovingAverage.ExponentiallyWeighted (+  ExponentiallyWeightedMovingAverage,+  new1MinuteMovingAverage,+  new5MinuteMovingAverage,+  new15MinuteMovingAverage,+  movingAverage,+  clear,+  rate,+  empty,+  update,+  tick+) where+import Control.Lens+import Control.Lens.TH+import Control.Monad.Primitive+import qualified Data.Metrics.MovingAverage as MA+import Data.Metrics.Types (Minutes)++-- | The internal representation of the exponentially weighted moving average.+--+-- This type encapsulates the state needed for the exponentially weighted "MovingAverage" implementation.+data ExponentiallyWeightedMovingAverage = ExponentiallyWeightedMovingAverage+  { _ewmaUncounted :: !Double+  , _ewmaCurrentRate :: !Double+  , _ewmaInitialized :: !Bool+  , _ewmaInterval :: !Double+  , _ewmaAlpha :: !Double+  } deriving (Show)++makeFields ''ExponentiallyWeightedMovingAverage++makeAlpha :: Double -> Minutes -> Double+makeAlpha i m = 1 - exp (negate i / 60 / fromIntegral m)++-- | Create a new "MovingAverage" with 5 second tick intervals for a one-minute window.+new1MinuteMovingAverage :: MA.MovingAverage+new1MinuteMovingAverage = movingAverage 5 1++-- | Create a new "MovingAverage" with 5 second tick intervals for a five-minute window.+new5MinuteMovingAverage :: MA.MovingAverage+new5MinuteMovingAverage = movingAverage 5 5++-- | Create a new "MovingAverage" with 5 second tick intervals for a fifteen-minute window.+new15MinuteMovingAverage :: MA.MovingAverage+new15MinuteMovingAverage = movingAverage 5 15++-- | Create a new "MovingAverage" with the given tick interval and averaging window.+movingAverage :: Double -> Minutes -> MA.MovingAverage+movingAverage i m = MA.MovingAverage+  { MA.movingAverageClear = clear+  , MA.movingAverageUpdate = update+  , MA.movingAverageTick = tick+  , MA.movingAverageRate = rate+  , MA.movingAverageState = empty i m+  }++-- | Reset the moving average rate to zero.+clear :: ExponentiallyWeightedMovingAverage -> ExponentiallyWeightedMovingAverage+clear = (initialized .~ False) . (currentRate .~ 0) . (uncounted .~ 0)++-- | Get the current rate of the "ExponentiallyWeightedMovingAverage" for the given window.+rate :: ExponentiallyWeightedMovingAverage -> Double+rate e = (e ^. currentRate) * (e ^. interval)++-- | Create a new "ExpontiallyWeightedMovingAverage" with the given tick interval and averaging window.+empty :: Double -- ^ The interval in seconds between ticks+  -> Minutes -- ^ The duration in minutes which the moving average covers+  -> ExponentiallyWeightedMovingAverage+empty i m = ExponentiallyWeightedMovingAverage 0 0 False i $ makeAlpha i m++-- | Update the moving average based upon the given value+update :: Double -> ExponentiallyWeightedMovingAverage -> ExponentiallyWeightedMovingAverage+update = (uncounted +~)++-- | Update the moving average as if the given interval between ticks has passed.+tick :: ExponentiallyWeightedMovingAverage -> ExponentiallyWeightedMovingAverage+tick e = uncounted .~ 0 $ initialized .~ True $ updateRate e+  where+    instantRate = (e ^. uncounted) / (e ^. interval)+    updateRate a = if a ^. initialized+      then currentRate +~ ((a ^. alpha) * (instantRate - a ^. currentRate)) $ a+      else currentRate .~ instantRate $ a
+ src/Data/Metrics/Registry.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE FlexibleInstances #-}+-- | 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.+module Data.Metrics.Registry (+  MetricRegistry,+  Metric(..),+  Register(..),+  module Data.Metrics.Types+) where+import Control.Concurrent.MVar+import qualified Data.HashMap.Strict as H+import Data.Metrics.Counter+import Data.Metrics.Gauge+import Data.Metrics.Histogram+import Data.Metrics.Meter+import Data.Metrics.Timer+import Data.Metrics.Types+import Data.Text (Text)++-- | A container that tracks all metrics registered with it.+-- All forms of metrics share the same namespace in the registry.+-- Consequently, attempting to replace a metric with one of a different type will fail (return Nothing from a call to `register`).+data MetricRegistry m = MetricRegistry+  { metrics :: !(MVar (H.HashMap Text (Metric m)))+  }++-- | A sum type of all supported metric types that reporters should be able to output.+data Metric m+  = MetricGauge !(Gauge m)+  | MetricCounter !(Counter m)+  | MetricHistogram !(Histogram m)+  | MetricMeter !(Meter m)+  | MetricTimer !(Timer m)++-- | Add a new metric to a registry or retrieve the existing metric of the same name if one exists.+class Register a where+  -- | 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.+  register :: MetricRegistry IO -> Text -> IO a -> IO (Maybe a)++instance Register (Counter IO) where+  register r t m = do+    hm <- takeMVar $ metrics r+    case H.lookup t hm of+      Nothing -> do+        c <- m+        putMVar (metrics r) $! H.insert t (MetricCounter c) hm+        return $! Just c+      Just im -> do+        putMVar (metrics r) hm+        return $! case im of+          MetricCounter c -> Just c+          _ -> Nothing++instance Register (Gauge IO) where+  register r t m = do+    hm <- takeMVar $ metrics r+    case H.lookup t hm of+      Nothing -> do+        g <- m+        putMVar (metrics r) $! H.insert t (MetricGauge g) hm+        return $! Just g+      Just im -> do+        putMVar (metrics r) hm+        return $! case im of+          MetricGauge r -> Just r+          _ -> Nothing++instance Register (Histogram IO) where+  register r t m = do+    hm <- takeMVar $ metrics r+    case H.lookup t hm of+      Nothing -> do+        h <- m+        putMVar (metrics r) $! H.insert t (MetricHistogram h) hm+        return $! Just h+      Just im -> do+        putMVar (metrics r) hm+        return $! case im of+          MetricHistogram h -> Just h+          _ -> Nothing++instance Register (Meter IO) where+  register r t m = do+    hm <- takeMVar $ metrics r+    case H.lookup t hm of+      Nothing -> do+        mv <- m+        putMVar (metrics r) $! H.insert t (MetricMeter mv) hm+        return $! Just mv+      Just im -> do+        putMVar (metrics r) hm+        return $! case im of+          MetricMeter md -> Just md+          _ -> Nothing++instance Register (Timer IO) where+  register r t m = do+    hm <- takeMVar $ metrics r+    case H.lookup t hm of+      Nothing -> do+        mv <- m+        putMVar (metrics r) $! H.insert t (MetricTimer mv) hm+        return $! Just mv+      Just im -> do+        putMVar (metrics r) hm+        return $! case im of+          MetricTimer md -> Just md+          _ -> Nothing
+ src/Data/Metrics/Reporter/StdOut.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE OverloadedStrings #-}+-- | Logging to stdout is primarily intended for development purposes or creating command line status tools.+--+-- For more meaningful access to statistics, metrics should be sent to something like Librato or Graphite.+module Data.Metrics.Reporter.StdOut (+  printHealthCheck,+  printHealthChecks+) where+import qualified Data.HashMap.Strict as H+import Data.HealthCheck+import Data.Metrics.Internal+import Data.Metrics.Types+import qualified Data.Text as T+import qualified Data.Text.IO as T+import System.Console.ANSI++--prettyPrintMetric (m, v) = T.putStr m >> T.putStr ": " >> putStrLn (show v)++--reportMetrics :: MetricRegistry -> IO ()+--reportMetrics m = dumpMetrics m >>= mapM_ prettyPrintMetric++--dumpMetrics :: MetricRegistry -> IO [(T.Text, Double)]+--dumpMetrics r = do+--  ms <- readMVar $ metrics r+--  -- let readRep (k, (repAction, _)) = repAction >>= \rep -> return (k, rep)+--  -- mapM readRep $ H.toList ms+--  return []+fg = SetColor Foreground Vivid++-- | Pretty-print a single HealthCheck to the console using ANSI colors.+printHealthCheck :: HealthCheck -> IO ()+printHealthCheck (HealthCheck m name) = do+  s <- m+  setSGR $ case status s of+    Good -> [fg Green]+    Bad -> [fg Red]+    Ugly -> [fg Yellow]+    Unknown -> [fg Cyan]+  T.putStr "● "+  setSGR [Reset]+  T.putStr name+  maybe (T.putStr "\n") (\msg -> T.putStr ": " >> T.putStrLn msg) $ statusMessage s++-- | Pretty-print a list of HealthChecks to the console using ANSI colors.+printHealthChecks :: HealthChecks -> IO ()+printHealthChecks = mapM_ printHealthCheck
+ src/Data/Metrics/Reservoir.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE ExistentialQuantification #-}+-- | A reservoir is the internal storage mechanism for a "Histogram".+-- It provides a generic way to store histogram values in a way that+-- allows us to avoid the need to plumb the implementation type through anything+-- that uses a reservoir.+module Data.Metrics.Reservoir where+import Data.Metrics.Snapshot+import Data.Time.Clock++-- | Encapsulates the internal state of a reservoir implementation.+--+-- The two standard implementations are the ExponentiallyDecayingReservoir and the UniformReservoir.+data Reservoir = forall s. Reservoir+  { _reservoirClear :: !(NominalDiffTime -> s -> s)+  -- ^ An operation that resets a reservoir to its initial state+  , _reservoirSize :: !(s -> Int)+  -- ^ Retrieve current size of the reservoir.+  -- This may or may not be constant depending on the specific implementation.+  , _reservoirSnapshot :: !(s -> Snapshot)+  -- ^ Take snapshot of the current reservoir.+  --+  -- The number of items in the snapshot should always match the reservoir's size.+  , _reservoirUpdate :: !(Double -> NominalDiffTime -> s -> s)+  -- ^ Add a new value to the reservoir, potentially evicting old values in the prcoess.+  , _reservoirState :: !s+  -- ^ The internal state of the reservoir.+  }++-- | Reset a reservoir to its initial state.+clear :: NominalDiffTime -> Reservoir -> Reservoir+clear t (Reservoir c size ss u st) = Reservoir c size ss u (c t st)++-- | Get the current number of elements in the reservoir+size :: Reservoir -> Int+size (Reservoir _ size _ _ st) = size st++-- | Get a copy of all elements in the reservoir.+snapshot :: Reservoir -> Snapshot+snapshot (Reservoir _ _ ss _ st) = ss st++-- | Update a reservoir with a new value.+--+-- N.B. for some reservoir types, the latest value is not guaranteed to be retained in the reservoir.+update :: Double -> NominalDiffTime -> Reservoir -> Reservoir+update x t (Reservoir c size ss u st) = Reservoir c size ss u (u x t st)
+ src/Data/Metrics/Reservoir/ExponentiallyDecaying.hs view
@@ -0,0 +1,165 @@+{-# LANGUAGE Rank2Types #-}+-- | A histogram with an exponentially decaying reservoir produces quantiles which are representative of (roughly) the last five minutes of data.+-- It does so by using a forward-decaying priority reservoir with an exponential weighting towards newer data.+-- 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.+-- Timers use histograms with exponentially decaying reservoirs by default.+module Data.Metrics.Reservoir.ExponentiallyDecaying (+  ExponentiallyDecayingReservoir,+  standardReservoir,+  reservoir,+  clear,+  size,+  snapshot,+  rescale,+  update+) where+import Control.Monad.Primitive+import Control.Monad.ST+import Data.Time.Clock+import Data.Time.Clock.POSIX+import Data.Metrics.Internal+import qualified Data.Metrics.Reservoir as R+import qualified Data.Map.Strict as M+import Data.Metrics.Snapshot (Snapshot(..), takeSnapshot)+import Data.Primitive.MutVar+import qualified Data.Vector.Unboxed as V+import Data.Word+import System.Posix.Time+import System.Posix.Types+import System.Random.MWC++-- hours in seconds+rescaleThreshold :: Word64+rescaleThreshold = 60 * 60++-- | A forward-decaying priority reservoir+--+-- <http://dimacs.rutgers.edu/~graham/pubs/papers/fwddecay.pdf>+data ExponentiallyDecayingReservoir = ExponentiallyDecayingReservoir+  { _edrSize :: !Int+  , _edrAlpha :: !Double+  , _edrRescaleThreshold :: !Word64+  , _edrReservoir :: !(M.Map Double Double)+  , _edrCount :: !Int+  , _edrStartTime :: !Word64+  , _edrNextScaleTime :: !Word64+  , _edrSeed :: !Seed+  } deriving (Show)++-- | An exponentially decaying reservoir with an alpha value of 0.015 and a 1028 sample cap.+--+-- This offers a 99.9% confidence level with a 5% margin of error assuming a normal distribution,+-- and an alpha factor of 0.015, which heavily biases the reservoir to the past 5 minutes of measurements.+standardReservoir :: NominalDiffTime -> Seed -> R.Reservoir+standardReservoir = reservoir 0.015 1028++-- | Create a reservoir with a custom alpha factor and reservoir size.+reservoir :: Double -- ^ alpha value+  -> Int -- ^ max reservoir size+  -> NominalDiffTime -- ^ creation time for the reservoir+  -> Seed -> R.Reservoir+reservoir a r t s = R.Reservoir+  { R._reservoirClear = clear+  , R._reservoirSize = size+  , R._reservoirSnapshot = snapshot+  , R._reservoirUpdate = update+  , R._reservoirState = ExponentiallyDecayingReservoir r a rescaleThreshold M.empty 0 c c' s+  }+  where+    c = truncate t+    c' = c + rescaleThreshold++-- | Reset the reservoir+clear :: NominalDiffTime -> ExponentiallyDecayingReservoir -> ExponentiallyDecayingReservoir+clear = go+  where+    go t c = c { _edrStartTime = t', _edrNextScaleTime = t'', _edrCount = 0, _edrReservoir = M.empty }+      where+        t' = truncate t+        t'' = t' + _edrRescaleThreshold c++-- | Get the current size of the reservoir.+size :: ExponentiallyDecayingReservoir -> Int+size = go+  where+    go r = min c s+      where+        c = _edrCount r+        s = _edrSize r++-- | Get a snapshot of the current reservoir+snapshot :: ExponentiallyDecayingReservoir -> Snapshot+snapshot r = runST $ do+  let svals = V.fromList $ M.elems $ _edrReservoir $ r+  mvals <- V.unsafeThaw svals+  takeSnapshot mvals++weight :: Double -> Word64 -> Double+weight alpha t = exp (alpha * fromIntegral t)++-- | \"A common feature of the above techniques—indeed, the key technique that+-- allows us to track the decayed weights efficiently – is that they maintain+-- counts and other quantities based on g(ti − L), and only scale by g(t − L)+-- at query time. But while g(ti −L)/g(t−L) is guaranteed to lie between zero+-- and one, the intermediate values of g(ti − L) could become very large. For+-- polynomial functions, these values should not grow too large, and should be+-- effectively represented in practice by floating point values without loss of+-- precision. For exponential functions, these values could grow quite large as+-- new values of (ti − L) become large, and potentially exceed the capacity of+-- common floating point types. However, since the values stored by the+-- algorithms are linear combinations of g values (scaled sums), they can be+-- rescaled relative to a new landmark. That is, by the analysis of exponential+-- decay in Section III-A, the choice of L does not affect the final result. We+-- can therefore multiply each value based on L by a factor of exp(−α(L′ − L)),+-- and obtain the correct value as if we had instead computed relative to a new+-- landmark L′ (and then use this new L′ at query time). This can be done with+-- a linear pass over whatever data structure is being used.\"+rescale :: Word64 -> ExponentiallyDecayingReservoir -> ExponentiallyDecayingReservoir+rescale now c = c+  { _edrReservoir = adjustedReservoir+  , _edrStartTime = now+  , _edrCount = M.size adjustedReservoir+  , _edrNextScaleTime = st+  }+  where+    potentialScaleTime = now + rescaleThreshold+    currentScaleTime = _edrNextScaleTime c+    st = if potentialScaleTime > currentScaleTime then potentialScaleTime else currentScaleTime+    diff = now - _edrStartTime c+    adjustKey x = x * exp (-alpha * fromIntegral diff)+    adjustedReservoir = M.mapKeys adjustKey $ _edrReservoir c+    alpha = _edrAlpha c++-- | Insert a new sample into the reservoir. This may cause old sample values to be evicted+-- based upon the probabilistic weighting given to the key at insertion time.+update :: Double -- ^ new sample value+  -> NominalDiffTime -- ^ time of update+  -> ExponentiallyDecayingReservoir+  -> ExponentiallyDecayingReservoir+update v t c = rescaled+  { _edrSeed = s'+  , _edrCount = newCount+  , _edrReservoir = addValue r+  } +  where+    rescaled = if seconds >= _edrNextScaleTime c+      then rescale seconds c+      else c+    seconds = truncate t+    priority = weight (_edrAlpha c) (seconds - _edrStartTime c) / priorityDenom+    addValue r = if newCount <= _edrSize c+      then M.insert priority v r+      else if firstKey < priority+        -- it should be safe to use head here since we are over our reservoir capacity at this point+        -- caveat: reservoir capped at 0 max size+        then M.delete firstKey $ M.insertWith const priority v r+        else r+    r = _edrReservoir c+    firstKey = head $ M.keys r+    newCount = 1 + _edrCount c+    (priorityDenom, s') = runST $ do+      g <- restore $ _edrSeed c+      p <- uniform g+      s' <- save g+      return (p :: Double, s')+
+ src/Data/Metrics/Reservoir/Uniform.hs view
@@ -0,0 +1,139 @@+-- | A histogram with a uniform reservoir produces quantiles which are valid for the entirely of the histogram’s lifetime.+-- It will return a median value, for example, which is the median of all the values the histogram has ever been updated with.+-- It does this by using an algorithm called Vitter’s R), which randomly selects values for the reservoir with linearly-decreasing probability.+--+-- Use a uniform histogram when you’re interested in long-term measurements.+-- Don’t use one where you’d want to know if the distribution of the underlying data stream has changed recently.+module Data.Metrics.Reservoir.Uniform (+  UniformReservoir,+  reservoir,+  unsafeReservoir,+  clear,+  unsafeClear,+  size,+  snapshot,+  update,+  unsafeUpdate+) where+import Control.Monad.ST+import Data.Metrics.Internal+import Data.Time.Clock+import qualified Data.Metrics.Reservoir as R+import qualified Data.Metrics.Snapshot as S+import Data.Primitive.MutVar+import System.Random.MWC+import qualified Data.Vector.Unboxed as I+import qualified Data.Vector.Unboxed.Mutable as V++-- | Make a safe uniform reservoir. This variant provides safe access at the expense of updates costing O(n)+reservoir :: Seed+  -> Int -- ^ maximum reservoir size+  -> R.Reservoir+reservoir g r = R.Reservoir+  { R._reservoirClear = clear+  , R._reservoirSize = size+  , R._reservoirSnapshot = snapshot+  , R._reservoirUpdate = update+  , R._reservoirState = UniformReservoir 0 (I.replicate r 0) g+  }++-- | Using this variant requires that you ensure that there is no sharing of the reservoir itself.+--+-- In other words, there must only be a single point of access (an IORef, etc. that accepts some sort of modification function).+--+-- In return, updating the reservoir becomes an O(1) operation and clearing the reservoir avoids extra allocations.+unsafeReservoir :: Seed -> Int -> R.Reservoir+unsafeReservoir g r = R.Reservoir+  { R._reservoirClear = unsafeClear+  , R._reservoirSize = size+  , R._reservoirSnapshot = snapshot+  , R._reservoirUpdate = unsafeUpdate+  , R._reservoirState = UniformReservoir 0 (I.replicate r 0) g+  }++-- | A reservoir in which all samples are equally likely to be evicted when the reservoir is at full capacity.+--+-- This is conceptually simpler than the "ExponentiallyDecayingReservoir", but at the expense of providing a less accurate sample.+data UniformReservoir = UniformReservoir+  { _urCount :: !Int+  , _urReservoir :: !(I.Vector Double)+  , _urSeed :: !Seed+  }++-- | Reset the reservoir to empty.+clear :: NominalDiffTime -> UniformReservoir -> UniformReservoir+clear = go+  where+    go _ c = c { _urCount = 0, _urReservoir = newRes $ _urReservoir c }+    newRes v = runST $ do+      v' <- I.thaw v+      V.set v' 0+      I.unsafeFreeze v'++-- | Reset the reservoir to empty by performing an in-place modification of the reservoir.+unsafeClear :: NominalDiffTime -> UniformReservoir -> UniformReservoir+unsafeClear = go+  where+    go _ c = c { _urCount = 0, _urReservoir = newRes $ _urReservoir c }+    newRes v = runST $ do+      v' <- I.unsafeThaw v+      V.set v' 0+      I.unsafeFreeze v'++-- | Get the current size of the reservoir+size :: UniformReservoir -> Int+size = go+  where+    go c = min (_urCount c) (I.length $ _urReservoir c)++-- | Take a snapshot of the reservoir by doing an in-place unfreeze.+--+-- This should be safe as long as unsafe operations are performed appropriately.+snapshot :: UniformReservoir -> S.Snapshot+snapshot = go+  where+    go c = runST $ do+      v' <- I.unsafeThaw $ _urReservoir c+      S.takeSnapshot $ V.slice 0 (size c) v'++-- | Perform an update of the reservoir by copying the internal vector. O(n)+update :: Double -> NominalDiffTime -> UniformReservoir -> UniformReservoir+update = go+  where+    go x _ c = c { _urCount = newCount, _urReservoir = newRes, _urSeed = newSeed }+      where+        newCount = succ $ _urCount c+        (newSeed, newRes) = runST $ do+          v' <- I.thaw $ _urReservoir c+          g <- restore (_urSeed c)+          if newCount <= V.length v'+            then V.unsafeWrite v' (_urCount c) x+            else do+              i <- uniformR (0, newCount) g+              if i < V.length v'+                then V.unsafeWrite v' i x+                else return ()+          v'' <- I.unsafeFreeze v'+          s <- save g+          return (s, v'')++-- | Perform an in-place update of the reservoir. O(1)+unsafeUpdate :: Double -> NominalDiffTime -> UniformReservoir -> UniformReservoir+unsafeUpdate = go+  where+    go x _ c = c { _urCount = newCount, _urReservoir = newRes, _urSeed = newSeed }+      where+        newCount = succ $ _urCount c+        (newSeed, newRes) = runST $ do+          v' <- I.unsafeThaw $ _urReservoir c+          g <- restore (_urSeed c)+          if newCount <= V.length v'+            then V.unsafeWrite v' (_urCount c) x+            else do+              i <- uniformR (0, newCount) g+              if i < V.length v'+                then V.unsafeWrite v' i x+                else return ()+          v'' <- I.unsafeFreeze v'+          s <- save g+          return (s, v'')
+ src/Data/Metrics/Snapshot.hs view
@@ -0,0 +1,100 @@+-- |+module Data.Metrics.Snapshot (+  Snapshot(..),+  quantile,+  size,+  median,+  get75thPercentile,+  get95thPercentile,+  get98thPercentile,+  get99thPercentile,+  get999thPercentile,+  takeSnapshot+) where+import Control.Monad.Primitive+import Data.Primitive.MutVar+import Data.Vector.Algorithms.Intro+import qualified Data.Vector.Unboxed as I+import qualified Data.Vector.Unboxed.Mutable as V++-- | A wrapper around a *sorted* vector intended for calculating quantile statistics.+newtype Snapshot = Snapshot+  { fromSnapshot :: I.Vector Double -- ^ A sorted "Vector" of samples.+  }+  deriving (Show)++medianQ :: Double+medianQ = 0.5++p75Q :: Double+p75Q = 0.75++p95Q :: Double+p95Q = 0.95++p98Q :: Double+p98Q = 0.98++p99Q :: Double+p99Q = 0.99++p999Q :: Double+p999Q = 0.999++clamp :: Double -> Double+clamp x = if x > 1+  then 1+  else if x < 0+    then 0+    else x++-- | A utility function for snapshotting data from an unsorted "MVector" of samples.+--+-- NB: this function uses "unsafeFreeze" under the hood, so be sure that the vector being+-- snapshotted is not used after calling this function.+takeSnapshot :: PrimMonad m => V.MVector (PrimState m) Double -> m Snapshot+takeSnapshot v = V.clone v >>= \v' -> sort v' >> I.unsafeFreeze v' >>= return . Snapshot++-- | Calculate an arbitrary quantile value for a "Snapshot".+-- Values below zero or greater than one will be clamped to the range [0, 1]+quantile :: Double -> Snapshot -> Double+quantile quantile (Snapshot s) = if pos > fromIntegral (I.length s)+  then I.last s+  else if pos' < 1+    then I.head s+    else lower + (pos - fromIntegral (floor pos :: Int)) * (upper - lower)+  where+    q = clamp quantile+    pos = q * (1 + (fromIntegral $ I.length s))+    pos' = truncate pos+    lower = I.unsafeIndex s (pos' - 1)+    upper = I.unsafeIndex s pos'++-- | Get the number of elements in a "Snapshot"+size :: Snapshot -> Int+size (Snapshot s) = I.length s++-- | Calculate the median value of a "Snapshot"+median :: Snapshot -> Double+median = quantile medianQ++-- | Calculate the 75th percentile of a "Snapshot"+get75thPercentile :: Snapshot -> Double+get75thPercentile = quantile p75Q++-- | Calculate the 95th percentile of a "Snapshot"+get95thPercentile :: Snapshot -> Double+get95thPercentile = quantile p95Q++-- | Calculate the 98th percentile of a "Snapshot"+get98thPercentile :: Snapshot -> Double+get98thPercentile = quantile p98Q++-- | Calculate the 99th percentile of a "Snapshot"+get99thPercentile :: Snapshot -> Double+get99thPercentile = quantile p99Q++-- | Calculate the 99.9th percentile of a "Snapshot"+get999thPercentile :: Snapshot -> Double+get999thPercentile = quantile p999Q+
+ src/Data/Metrics/Timer.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+-- | A timer is basically a histogram of the duration of a type of event and a meter of the rate of its occurrence.+module Data.Metrics.Timer (+  Timer,+  mkTimer,+  timer,+  time,+  module Data.Metrics.Types+) where+import Control.Applicative+import Control.Lens+import Control.Lens.TH+import Control.Monad.Primitive+import qualified Data.Metrics.MovingAverage.ExponentiallyWeighted as E+import qualified Data.Metrics.Histogram.Internal as H+import qualified Data.Metrics.Meter.Internal as M+import qualified Data.Metrics.Timer.Internal as P+import qualified Data.Metrics.Reservoir.ExponentiallyDecaying as R+import Data.Metrics.Internal+import Data.Metrics.Types+import Data.Primitive.MutVar+import Data.Time.Clock+import Data.Time.Clock.POSIX+import System.Random.MWC++-- | A measure of time statistics for the duration of an event+data Timer m = Timer+  { fromTimer :: !(MutVar (PrimState m) P.Timer) -- ^ A reference to the pure timer internals+  , _timerGetTime :: !(m NominalDiffTime) -- ^ The function that provides time differences for the timer. In practice, this is usually just "getPOSIXTime"+  }++makeFields ''Timer++instance PrimMonad m => Clear m (Timer m) where+  clear t = do+    ts <- _timerGetTime t+    updateRef (fromTimer t) $ P.clear ts++instance PrimMonad m => Update m (Timer m) Double where+  update t x = do+    ts <- _timerGetTime t+    updateRef (fromTimer t) $ P.update ts x++instance PrimMonad m => Count m (Timer m) where+  count t = readMutVar (fromTimer t) >>= return . P.count++instance (Functor m, PrimMonad m) => Statistics m (Timer m) where+  mean t = applyWithRef (fromTimer t) P.mean+  stddev t = applyWithRef (fromTimer t) P.stddev+  variance t = applyWithRef (fromTimer t) P.variance+  maxVal t = P.maxVal <$> readMutVar (fromTimer t)+  minVal t = P.minVal <$> readMutVar (fromTimer t)++instance PrimMonad m => Rate m (Timer m) where+  oneMinuteRate t = do+    ts <- _timerGetTime t+    updateAndApplyToRef (fromTimer t) (P.tickIfNecessary ts) P.oneMinuteRate+  fiveMinuteRate t = do+    ts <- _timerGetTime t+    updateAndApplyToRef (fromTimer t) (P.tickIfNecessary ts) P.fiveMinuteRate+  fifteenMinuteRate t = do+    ts <- _timerGetTime t+    updateAndApplyToRef (fromTimer t) (P.tickIfNecessary ts) P.fifteenMinuteRate+  meanRate t = do+    ts <- _timerGetTime t+    applyWithRef (fromTimer t) (P.meanRate ts)++instance PrimMonad m => TakeSnapshot m (Timer m) where+  snapshot t = applyWithRef (fromTimer t) P.snapshot++-- | Create a timer using a custom function for retrieving the current time.+--+-- This is mostly exposed for testing purposes: prefer using "timer" if possible.+mkTimer :: PrimMonad m => m NominalDiffTime -> Seed -> m (Timer m)+mkTimer mt s = do+  t <- mt+  let ewmaMeter = M.meterData (E.movingAverage 5) t+  let histogram = H.histogram $ R.reservoir 0.015 1028 t s+  v <- newMutVar $ P.Timer ewmaMeter histogram+  return $ Timer v mt++-- | Create a standard "Timer" with an +-- exponentially weighted moving average+-- and an exponentially decaying histogram+timer :: IO (Timer IO)+timer = do+  s <- withSystemRandom (asGenIO $ save)+  mkTimer getPOSIXTime s++-- | Execute an action and record statistics about the+-- duration of the event and the rate of event occurrence.+time :: Timer IO -> IO a -> IO a+time t m = do+  let gt = t ^. getTime+  ts <- gt+  r <- m+  tf <- gt+  update t $ realToFrac $ tf - ts+  return r+
+ src/Data/Metrics/Timer/Internal.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+-- | A timer is essentially just a data type that combines+-- a "Meter" and a "Histogram" to track both the rate at which+-- events are triggered as well as timing statistics about the calls.+--+-- This module exports the pure internals, relying on the stateful version+-- to supply the pure timer with measurements.+module Data.Metrics.Timer.Internal where+import Control.Lens+import Data.Time.Clock+import qualified Data.Metrics.Histogram.Internal as H+import qualified Data.Metrics.MovingAverage as A+import qualified Data.Metrics.Meter.Internal as M+import qualified Data.Metrics.Snapshot as S++data Timer = Timer+  { _timerMeter :: !M.Meter+  , _timerHistogram :: !H.Histogram+  }++makeFields ''Timer++tickIfNecessary :: NominalDiffTime -> Timer -> Timer+tickIfNecessary t = meter %~ M.tickIfNecessary t++snapshot :: Timer -> S.Snapshot+snapshot = H.snapshot . _timerHistogram++oneMinuteRate :: Timer -> Double+oneMinuteRate = A.rate . M.oneMinuteAverage . _timerMeter++fiveMinuteRate :: Timer -> Double+fiveMinuteRate = A.rate . M.fiveMinuteAverage . _timerMeter++fifteenMinuteRate :: Timer -> Double+fifteenMinuteRate = A.rate . M.fifteenMinuteAverage . _timerMeter++meanRate :: NominalDiffTime -> Timer -> Double+meanRate t = M.meanRate t . _timerMeter++count :: Timer -> Int+count = H.count . view histogram++clear :: NominalDiffTime -> Timer -> Timer+clear t = (histogram %~ H.clear t) . (meter %~ M.clear t)++update :: NominalDiffTime -> Double -> Timer -> Timer+update t x = (histogram %~ H.update x t) . (meter %~ M.mark t 1)++mean :: Timer -> Double+mean = H.mean . _timerHistogram++stddev :: Timer -> Double+stddev = H.stddev . _timerHistogram++variance :: Timer -> Double+variance = H.variance . _timerHistogram++maxVal :: Timer -> Double+maxVal = H.maxVal . _timerHistogram++minVal :: Timer -> Double+minVal = H.minVal . _timerHistogram
+ src/Data/Metrics/Types.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+-- | The main accessors for common stateful metric implementation data.+module Data.Metrics.Types where+import Control.Concurrent.MVar+import Control.Monad.Primitive+import Data.HashMap.Strict (HashMap)+import Data.Metrics.Internal+import Data.Metrics.Snapshot+import Data.Primitive.MutVar+import Data.Text (Text)+import Data.Vector.Unboxed (Vector)++-- | Histogram moving averages are tracked (by default) on minute scale.+type Minutes = Int++-- | Get the current count for the given metric.+class Count m a | a -> m where+  -- | retrieve a count+  count :: a -> m Int++-- | Provides statistics from a histogram that tracks the standard moving average rates.+class Rate m a | a -> m where+  -- | Get the average rate of occurrence for some sort of event for the past minute.+  oneMinuteRate :: a -> m Double+  -- | Get the average rate of occurrence for some sort of event for the past five minutes.+  fiveMinuteRate :: a -> m Double+  -- | Get the average rate of occurrence for some sort of event for the past fifteen minutes.+  fifteenMinuteRate :: a -> m Double+  -- | Get the mean rate of occurrence for some sort of event for the entirety of the time that 'a' has existed.+  meanRate :: a -> m Double++-- | Gets the current value from a simple metric (i.e. a "Counter" or a "Gauge")+class Value m a v | a -> m v where+  value :: a -> m v++-- | Update a metric by performing wholesale replacement of a value.+class Set m a v | a -> m v where+  -- | Replace the current value of a simple metric (i.e. a "Counter" or a "Gauge")+  set :: a -> v -> m ()++-- | Provides a way to reset metrics. This might be useful in a development environment+-- or to periodically get a clean state for long-running processes.+class Clear m a | a -> m where+  -- | Reset the metric to an 'empty' state. In practice, this should be+  -- equivalent to creating a new metric of the same type in-place.+  clear :: a -> m ()++-- | Provides the main interface for retrieving statistics tabulated by a histogram.+class Statistics m a | a -> m where+  -- | Gets the highest value encountered thus far.+  maxVal :: a -> m Double+  -- | Gets the lowest value encountered thus far.+  minVal :: a -> m Double+  -- | Gets the current average value. This may have slightly different meanings+  -- depending on the type of "MovingAverage" used.+  mean :: a -> m Double+  -- | Gets the standard deviation of all values encountered this var.+  stddev :: a -> m Double+  -- | Gets the variance of all values encountered this var.+  variance :: a -> m Double++-- | Update statistics tracked by a metric with a new sample.+class Update m a v | a -> m v where+  -- | Feed a metric another value.+  update :: a -> v -> m ()++-- | Take a snapshot (a sorted vector) of samples used for calculating quantile data.+class TakeSnapshot m a | a -> m where+  -- | Get a sample of the values currently in a histogram or type that contains a histogram.+  snapshot :: a -> m Snapshot
+ tests/Main.hs view
@@ -0,0 +1,17 @@+module Main where+import Control.Monad+import CounterTest+import GaugeTest+import EDR+import EWMA+-- import HistogramTest+import Test.QuickCheck+--import MeterTest+--import RegistryTest+--import TimerTest++main = mapM_ quickCheck $+  counterTests +++  gaugeTests +++  ewmaTests +++  edrTests