{-# language BangPatterns #-}
{-# language OverloadedStrings #-}

module Prometheus.Metric.Histogram (
    Histogram
,   Bucket
,   histogram
,   defaultBuckets
,   exponentialBuckets
,   linearBuckets

-- * Exported for testing
,   BucketCounts(..)
,   insert
,   emptyCounts
,   getHistogram
) where

import Prometheus.Info
import Prometheus.Metric
import Prometheus.Metric.Observer
import Prometheus.MonadMonitor

import Control.Applicative ((<$>))
import qualified Control.Concurrent.STM as STM
import Control.DeepSeq
import Control.Monad.IO.Class
import qualified Data.ByteString.UTF8 as BS
import qualified Data.Map.Strict as Map
import Data.Monoid ((<>))
import Data.Text (Text)
import qualified Data.Text as T
import Numeric (showFFloat)

-- | A histogram. Counts the number of observations that fall within the
-- specified buckets.
newtype Histogram = MkHistogram (STM.TVar BucketCounts)

instance NFData Histogram where
  rnf :: Histogram -> ()
rnf (MkHistogram TVar BucketCounts
a) = TVar BucketCounts -> () -> ()
forall a b. a -> b -> b
seq TVar BucketCounts
a ()

-- | Create a new 'Histogram' metric with a given name, help string, and
-- list of buckets. Panics if the list of buckets is not strictly increasing.
-- A good default list of buckets is 'defaultBuckets'. You can also create
-- buckets with 'linearBuckets' or 'exponentialBuckets'.
histogram :: Info -> [Bucket] -> Metric Histogram
histogram :: Info -> [Double] -> Metric Histogram
histogram Info
info [Double]
buckets = IO (Histogram, IO [SampleGroup]) -> Metric Histogram
forall s. IO (s, IO [SampleGroup]) -> Metric s
Metric (IO (Histogram, IO [SampleGroup]) -> Metric Histogram)
-> IO (Histogram, IO [SampleGroup]) -> Metric Histogram
forall a b. (a -> b) -> a -> b
$ do
  TVar BucketCounts
countsTVar <- BucketCounts -> IO (TVar BucketCounts)
forall a. a -> IO (TVar a)
STM.newTVarIO  ([Double] -> BucketCounts
emptyCounts [Double]
buckets)
  (Histogram, IO [SampleGroup]) -> IO (Histogram, IO [SampleGroup])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (TVar BucketCounts -> Histogram
MkHistogram TVar BucketCounts
countsTVar, Info -> TVar BucketCounts -> IO [SampleGroup]
collectHistogram Info
info TVar BucketCounts
countsTVar)

-- | Upper-bound for a histogram bucket.
type Bucket = Double

-- | Current state of a histogram.
data BucketCounts = BucketCounts {
    -- | The sum of all the observations.
    BucketCounts -> Double
histTotal :: !Double
    -- | The number of observations that have been made.
,   BucketCounts -> Int
histCount :: !Int
    -- | Counts for each bucket. The key is the upper-bound,
    -- value is the number of observations less-than-or-equal-to
    -- that upper bound, but greater than the next lowest upper bound.
,   BucketCounts -> Map Double Int
histCountsPerBucket :: !(Map.Map Bucket Int)
} deriving (Int -> BucketCounts -> ShowS
[BucketCounts] -> ShowS
BucketCounts -> [Char]
(Int -> BucketCounts -> ShowS)
-> (BucketCounts -> [Char])
-> ([BucketCounts] -> ShowS)
-> Show BucketCounts
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BucketCounts -> ShowS
showsPrec :: Int -> BucketCounts -> ShowS
$cshow :: BucketCounts -> [Char]
show :: BucketCounts -> [Char]
$cshowList :: [BucketCounts] -> ShowS
showList :: [BucketCounts] -> ShowS
Show, BucketCounts -> BucketCounts -> Bool
(BucketCounts -> BucketCounts -> Bool)
-> (BucketCounts -> BucketCounts -> Bool) -> Eq BucketCounts
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BucketCounts -> BucketCounts -> Bool
== :: BucketCounts -> BucketCounts -> Bool
$c/= :: BucketCounts -> BucketCounts -> Bool
/= :: BucketCounts -> BucketCounts -> Bool
Eq, Eq BucketCounts
Eq BucketCounts =>
(BucketCounts -> BucketCounts -> Ordering)
-> (BucketCounts -> BucketCounts -> Bool)
-> (BucketCounts -> BucketCounts -> Bool)
-> (BucketCounts -> BucketCounts -> Bool)
-> (BucketCounts -> BucketCounts -> Bool)
-> (BucketCounts -> BucketCounts -> BucketCounts)
-> (BucketCounts -> BucketCounts -> BucketCounts)
-> Ord BucketCounts
BucketCounts -> BucketCounts -> Bool
BucketCounts -> BucketCounts -> Ordering
BucketCounts -> BucketCounts -> BucketCounts
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: BucketCounts -> BucketCounts -> Ordering
compare :: BucketCounts -> BucketCounts -> Ordering
$c< :: BucketCounts -> BucketCounts -> Bool
< :: BucketCounts -> BucketCounts -> Bool
$c<= :: BucketCounts -> BucketCounts -> Bool
<= :: BucketCounts -> BucketCounts -> Bool
$c> :: BucketCounts -> BucketCounts -> Bool
> :: BucketCounts -> BucketCounts -> Bool
$c>= :: BucketCounts -> BucketCounts -> Bool
>= :: BucketCounts -> BucketCounts -> Bool
$cmax :: BucketCounts -> BucketCounts -> BucketCounts
max :: BucketCounts -> BucketCounts -> BucketCounts
$cmin :: BucketCounts -> BucketCounts -> BucketCounts
min :: BucketCounts -> BucketCounts -> BucketCounts
Ord)

emptyCounts :: [Bucket] -> BucketCounts
emptyCounts :: [Double] -> BucketCounts
emptyCounts [Double]
buckets
    | [Double] -> Bool
forall {b}. Ord b => [b] -> Bool
isStrictlyIncreasing [Double]
buckets = Double -> Int -> Map Double Int -> BucketCounts
BucketCounts Double
0 Int
0 (Map Double Int -> BucketCounts) -> Map Double Int -> BucketCounts
forall a b. (a -> b) -> a -> b
$ [(Double, Int)] -> Map Double Int
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([Double] -> [Int] -> [(Double, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Double]
buckets (Int -> [Int]
forall a. a -> [a]
repeat Int
0))
    | Bool
otherwise = [Char] -> BucketCounts
forall a. HasCallStack => [Char] -> a
error ([Char]
"Histogram buckets must be in increasing order, got: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Double] -> [Char]
forall a. Show a => a -> [Char]
show [Double]
buckets)
    where
         isStrictlyIncreasing :: [b] -> Bool
isStrictlyIncreasing [b]
xs = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((b -> b -> Bool) -> [b] -> [b] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith b -> b -> Bool
forall a. Ord a => a -> a -> Bool
(<) [b]
xs ([b] -> [b]
forall a. HasCallStack => [a] -> [a]
tail [b]
xs))

instance Observer Histogram where
    -- | Add a new observation to a histogram metric.
    observe :: forall (m :: * -> *). MonadMonitor m => Histogram -> Double -> m ()
observe Histogram
h Double
v = Histogram -> (BucketCounts -> BucketCounts) -> m ()
forall (m :: * -> *).
MonadMonitor m =>
Histogram -> (BucketCounts -> BucketCounts) -> m ()
withHistogram Histogram
h (Double -> BucketCounts -> BucketCounts
insert Double
v)

-- | Transform the contents of a histogram.
withHistogram :: MonadMonitor m
              => Histogram -> (BucketCounts -> BucketCounts) -> m ()
withHistogram :: forall (m :: * -> *).
MonadMonitor m =>
Histogram -> (BucketCounts -> BucketCounts) -> m ()
withHistogram (MkHistogram !TVar BucketCounts
bucketCounts) BucketCounts -> BucketCounts
f =
  IO () -> m ()
forall (m :: * -> *). MonadMonitor m => IO () -> m ()
doIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar BucketCounts -> (BucketCounts -> BucketCounts) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
STM.modifyTVar' TVar BucketCounts
bucketCounts BucketCounts -> BucketCounts
f

-- | Retries a map of upper bounds to counts of values observed that are
-- less-than-or-equal-to that upper bound, but greater than any other upper
-- bound in the map.
getHistogram :: MonadIO m => Histogram -> m (Map.Map Bucket Int)
getHistogram :: forall (m :: * -> *). MonadIO m => Histogram -> m (Map Double Int)
getHistogram (MkHistogram TVar BucketCounts
bucketsTVar) =
    IO (Map Double Int) -> m (Map Double Int)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map Double Int) -> m (Map Double Int))
-> IO (Map Double Int) -> m (Map Double Int)
forall a b. (a -> b) -> a -> b
$ BucketCounts -> Map Double Int
histCountsPerBucket (BucketCounts -> Map Double Int)
-> IO BucketCounts -> IO (Map Double Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM BucketCounts -> IO BucketCounts
forall a. STM a -> IO a
STM.atomically (TVar BucketCounts -> STM BucketCounts
forall a. TVar a -> STM a
STM.readTVar TVar BucketCounts
bucketsTVar)

-- | Record an observation.
insert :: Double -> BucketCounts -> BucketCounts
insert :: Double -> BucketCounts -> BucketCounts
insert Double
value BucketCounts { histTotal :: BucketCounts -> Double
histTotal = Double
total, histCount :: BucketCounts -> Int
histCount = Int
count, histCountsPerBucket :: BucketCounts -> Map Double Int
histCountsPerBucket = Map Double Int
counts } =
    Double -> Int -> Map Double Int -> BucketCounts
BucketCounts (Double
total Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
value) (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Map Double Int
incCounts
    where
        incCounts :: Map Double Int
incCounts =
            case Double -> Map Double Int -> Maybe (Double, Int)
forall k v. Ord k => k -> Map k v -> Maybe (k, v)
Map.lookupGE Double
value Map Double Int
counts of
                Maybe (Double, Int)
Nothing -> Map Double Int
counts
                Just (Double
upperBound, Int
_) -> (Int -> Int) -> Double -> Map Double Int -> Map Double Int
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Double
upperBound Map Double Int
counts

-- | Collect the current state of a histogram.
collectHistogram :: Info -> STM.TVar BucketCounts -> IO [SampleGroup]
collectHistogram :: Info -> TVar BucketCounts -> IO [SampleGroup]
collectHistogram Info
info TVar BucketCounts
bucketCounts = STM [SampleGroup] -> IO [SampleGroup]
forall a. STM a -> IO a
STM.atomically (STM [SampleGroup] -> IO [SampleGroup])
-> STM [SampleGroup] -> IO [SampleGroup]
forall a b. (a -> b) -> a -> b
$ do
    BucketCounts Double
total Int
count Map Double Int
counts <- TVar BucketCounts -> STM BucketCounts
forall a. TVar a -> STM a
STM.readTVar TVar BucketCounts
bucketCounts
    let sumSample :: Sample
sumSample = Text -> LabelPairs -> ByteString -> Sample
Sample (Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_sum") [] (Double -> ByteString
forall s. Show s => s -> ByteString
bsShow Double
total)
    let countSample :: Sample
countSample = Text -> LabelPairs -> ByteString -> Sample
Sample (Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_count") [] (Int -> ByteString
forall s. Show s => s -> ByteString
bsShow Int
count)
    let infSample :: Sample
infSample = Text -> LabelPairs -> ByteString -> Sample
Sample (Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_bucket") [(Text
bucketLabel, Text
"+Inf")] (Int -> ByteString
forall s. Show s => s -> ByteString
bsShow Int
count)
    let samples :: [Sample]
samples = ((Double, Int) -> Sample) -> [(Double, Int)] -> [Sample]
forall a b. (a -> b) -> [a] -> [b]
map (Double, Int) -> Sample
forall {s} {a}. (Show s, RealFloat a) => (a, s) -> Sample
toSample ([(Double, Int)] -> [(Double, Int)]
forall {b} {a}. Num b => [(a, b)] -> [(a, b)]
cumulativeSum (Map Double Int -> [(Double, Int)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map Double Int
counts))
    [SampleGroup] -> STM [SampleGroup]
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return [Info -> SampleType -> [Sample] -> SampleGroup
SampleGroup Info
info SampleType
HistogramType ([Sample] -> SampleGroup) -> [Sample] -> SampleGroup
forall a b. (a -> b) -> a -> b
$ [Sample]
samples [Sample] -> [Sample] -> [Sample]
forall a. [a] -> [a] -> [a]
++ [Sample
infSample, Sample
sumSample, Sample
countSample]]
    where
        toSample :: (a, s) -> Sample
toSample (a
upperBound, s
count') =
            Text -> LabelPairs -> ByteString -> Sample
Sample (Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_bucket") [(Text
bucketLabel, a -> Text
forall {a}. RealFloat a => a -> Text
formatFloat a
upperBound)] (ByteString -> Sample) -> ByteString -> Sample
forall a b. (a -> b) -> a -> b
$ s -> ByteString
forall s. Show s => s -> ByteString
bsShow s
count'
        name :: Text
name = Info -> Text
metricName Info
info

        -- We don't particularly want scientific notation, so force regular
        -- numeric representation instead.
        formatFloat :: a -> Text
formatFloat a
x = [Char] -> Text
T.pack (Maybe Int -> a -> ShowS
forall a. RealFloat a => Maybe Int -> a -> ShowS
showFFloat Maybe Int
forall a. Maybe a
Nothing a
x [Char]
"")

        cumulativeSum :: [(a, b)] -> [(a, b)]
cumulativeSum [(a, b)]
xs = [a] -> [b] -> [(a, b)]
forall a b. [a] -> [b] -> [(a, b)]
zip (((a, b) -> a) -> [(a, b)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a, b) -> a
forall a b. (a, b) -> a
fst [(a, b)]
xs) ((b -> b -> b) -> [b] -> [b]
forall a. (a -> a -> a) -> [a] -> [a]
scanl1 b -> b -> b
forall a. Num a => a -> a -> a
(+) (((a, b) -> b) -> [(a, b)] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (a, b) -> b
forall a b. (a, b) -> b
snd [(a, b)]
xs))

        bsShow :: Show s => s -> BS.ByteString
        bsShow :: forall s. Show s => s -> ByteString
bsShow = [Char] -> ByteString
BS.fromString ([Char] -> ByteString) -> (s -> [Char]) -> s -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> [Char]
forall a. Show a => a -> [Char]
show

-- | The label that defines the upper bound of a bucket of a histogram. @"le"@
-- is short for "less than or equal to".
bucketLabel :: Text
bucketLabel :: Text
bucketLabel = Text
"le"

-- | The default Histogram buckets. These are tailored to measure the response
-- time (in seconds) of a network service. You will almost certainly need to
-- customize them for your particular use case.
defaultBuckets :: [Double]
defaultBuckets :: [Double]
defaultBuckets = [Double
0.005, Double
0.01, Double
0.025, Double
0.05, Double
0.1, Double
0.25, Double
0.5, Double
1, Double
2.5, Double
5, Double
10]

-- | Create @count@ buckets, each @width@ wide, where the lowest bucket has an
-- upper bound of @start@. Use this to create buckets for 'histogram'.
linearBuckets :: Bucket -> Double -> Int -> [Bucket]
linearBuckets :: Double -> Double -> Int -> [Double]
linearBuckets Double
start Double
width Int
count
    | Int
count Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = [Char] -> [Double]
forall a. HasCallStack => [Char] -> a
error ([Char]
"Must provide a positive number of linear buckets, got: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
count)
    | Bool
otherwise = Int -> [Double] -> [Double]
forall a. Int -> [a] -> [a]
take Int
count ((Double -> Double) -> Double -> [Double]
forall a. (a -> a) -> a -> [a]
iterate (Double
widthDouble -> Double -> Double
forall a. Num a => a -> a -> a
+) Double
start)

-- | Create @count@ buckets, where the lowest bucket has an upper bound of @start@
-- and each bucket's upper bound is @factor@ times the previous bucket's upper bound.
-- Use this to create buckets for 'histogram'.
exponentialBuckets :: Bucket -> Double -> Int -> [Bucket]
exponentialBuckets :: Double -> Double -> Int -> [Double]
exponentialBuckets Double
start Double
factor Int
count
    | Int
count Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = [Char] -> [Double]
forall a. HasCallStack => [Char] -> a
error ([Char]
"Must provide a positive number of exponential buckets, got: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
count)
    | Double
factor Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
1 = [Char] -> [Double]
forall a. HasCallStack => [Char] -> a
error ([Char]
"Exponential buckets must have factor greater than 1 to ensure upper bounds are monotonically increasing, got: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Double -> [Char]
forall a. Show a => a -> [Char]
show Double
factor)
    | Double
start Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
0 = [Char] -> [Double]
forall a. HasCallStack => [Char] -> a
error ([Char]
"Exponential buckets must have positive number for start bucket to ensure upper bounds are monotonically increasing, got: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Double -> [Char]
forall a. Show a => a -> [Char]
show Double
start)
    | Bool
otherwise = Int -> [Double] -> [Double]
forall a. Int -> [a] -> [a]
take Int
count ((Double -> Double) -> Double -> [Double]
forall a. (a -> a) -> a -> [a]
iterate (Double
factorDouble -> Double -> Double
forall a. Num a => a -> a -> a
*) Double
start)