{-# 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) = seq :: 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 = forall s. IO (s, IO [SampleGroup]) -> Metric s
Metric forall a b. (a -> b) -> a -> b
$ do
  TVar BucketCounts
countsTVar <- forall a. a -> IO (TVar a)
STM.newTVarIO  ([Double] -> BucketCounts
emptyCounts [Double]
buckets)
  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]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [BucketCounts] -> ShowS
$cshowList :: [BucketCounts] -> ShowS
show :: BucketCounts -> [Char]
$cshow :: BucketCounts -> [Char]
showsPrec :: Int -> BucketCounts -> ShowS
$cshowsPrec :: Int -> BucketCounts -> ShowS
Show, BucketCounts -> BucketCounts -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BucketCounts -> BucketCounts -> Bool
$c/= :: BucketCounts -> BucketCounts -> Bool
== :: BucketCounts -> BucketCounts -> Bool
$c== :: BucketCounts -> BucketCounts -> Bool
Eq, Eq 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
min :: BucketCounts -> BucketCounts -> BucketCounts
$cmin :: BucketCounts -> BucketCounts -> BucketCounts
max :: BucketCounts -> BucketCounts -> BucketCounts
$cmax :: BucketCounts -> BucketCounts -> BucketCounts
>= :: BucketCounts -> BucketCounts -> Bool
$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
compare :: BucketCounts -> BucketCounts -> Ordering
$ccompare :: BucketCounts -> BucketCounts -> Ordering
Ord)

emptyCounts :: [Bucket] -> BucketCounts
emptyCounts :: [Double] -> BucketCounts
emptyCounts [Double]
buckets
    | forall {b}. Ord b => [b] -> Bool
isStrictlyIncreasing [Double]
buckets = Double -> Int -> Map Double Int -> BucketCounts
BucketCounts Double
0 Int
0 forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (forall a b. [a] -> [b] -> [(a, b)]
zip [Double]
buckets (forall a. a -> [a]
repeat Int
0))
    | Bool
otherwise = forall a. HasCallStack => [Char] -> a
error ([Char]
"Histogram buckets must be in increasing order, got: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [Double]
buckets)
    where
         isStrictlyIncreasing :: [b] -> Bool
isStrictlyIncreasing [b]
xs = forall (t :: * -> *). Foldable t => t Bool -> Bool
and (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a. Ord a => a -> a -> Bool
(<) [b]
xs (forall a. [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 = 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 =
  forall (m :: * -> *). MonadMonitor m => IO () -> m ()
doIO forall a b. (a -> b) -> a -> b
$ forall a. STM a -> IO a
STM.atomically forall a b. (a -> b) -> a -> b
$ 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) =
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ BucketCounts -> Map Double Int
histCountsPerBucket forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. STM a -> IO a
STM.atomically (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 forall a. Num a => a -> a -> a
+ Double
value) (Int
count forall a. Num a => a -> a -> a
+ Int
1) Map Double Int
incCounts
    where
        incCounts :: Map Double Int
incCounts =
            case 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
_) -> forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust (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 = forall a. STM a -> IO a
STM.atomically forall a b. (a -> b) -> a -> b
$ do
    BucketCounts Double
total Int
count Map Double Int
counts <- forall a. TVar a -> STM a
STM.readTVar TVar BucketCounts
bucketCounts
    let sumSample :: Sample
sumSample = Text -> LabelPairs -> ByteString -> Sample
Sample (Text
name forall a. Semigroup a => a -> a -> a
<> Text
"_sum") [] (forall s. Show s => s -> ByteString
bsShow Double
total)
    let countSample :: Sample
countSample = Text -> LabelPairs -> ByteString -> Sample
Sample (Text
name forall a. Semigroup a => a -> a -> a
<> Text
"_count") [] (forall s. Show s => s -> ByteString
bsShow Int
count)
    let infSample :: Sample
infSample = Text -> LabelPairs -> ByteString -> Sample
Sample (Text
name forall a. Semigroup a => a -> a -> a
<> Text
"_bucket") [(Text
bucketLabel, Text
"+Inf")] (forall s. Show s => s -> ByteString
bsShow Int
count)
    let samples :: [Sample]
samples = forall a b. (a -> b) -> [a] -> [b]
map forall {s} {a}. (Show s, RealFloat a) => (a, s) -> Sample
toSample (forall {b} {a}. Num b => [(a, b)] -> [(a, b)]
cumulativeSum (forall k a. Map k a -> [(k, a)]
Map.toAscList Map Double Int
counts))
    forall (m :: * -> *) a. Monad m => a -> m a
return [Info -> SampleType -> [Sample] -> SampleGroup
SampleGroup Info
info SampleType
HistogramType forall a b. (a -> b) -> a -> b
$ [Sample]
samples 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 forall a. Semigroup a => a -> a -> a
<> Text
"_bucket") [(Text
bucketLabel, forall {a}. RealFloat a => a -> Text
formatFloat a
upperBound)] forall a b. (a -> b) -> a -> b
$ 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 (forall a. RealFloat a => Maybe Int -> a -> ShowS
showFFloat forall a. Maybe a
Nothing a
x [Char]
"")

        cumulativeSum :: [(a, b)] -> [(a, b)]
cumulativeSum [(a, b)]
xs = forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(a, b)]
xs) (forall a. (a -> a -> a) -> [a] -> [a]
scanl1 forall a. Num a => a -> a -> a
(+) (forall a b. (a -> b) -> [a] -> [b]
map 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a. Ord a => a -> a -> Bool
<= Int
0 = forall a. HasCallStack => [Char] -> a
error ([Char]
"Must provide a positive number of linear buckets, got: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
count)
    | Bool
otherwise = forall a. Int -> [a] -> [a]
take Int
count (forall a. (a -> a) -> a -> [a]
iterate (Double
widthforall 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 forall a. Ord a => a -> a -> Bool
<= Int
0 = forall a. HasCallStack => [Char] -> a
error ([Char]
"Must provide a positive number of exponential buckets, got: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
count)
    | Double
factor forall a. Ord a => a -> a -> Bool
<= Double
1 = forall a. HasCallStack => [Char] -> a
error ([Char]
"Exponential buckets must have factor greater than 1 to ensure upper bounds are monotonically increasing, got: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Double
factor)
    | Double
start forall a. Ord a => a -> a -> Bool
<= Double
0 = forall a. HasCallStack => [Char] -> a
error ([Char]
"Exponential buckets must have positive number for start bucket to ensure upper bounds are monotonically increasing, got: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Double
start)
    | Bool
otherwise = forall a. Int -> [a] -> [a]
take Int
count (forall a. (a -> a) -> a -> [a]
iterate (Double
factorforall a. Num a => a -> a -> a
*) Double
start)