{-# 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 -> () -> ()
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 -> [Bucket] -> Metric Histogram
histogram Info
info [Bucket]
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  ([Bucket] -> BucketCounts
emptyCounts [Bucket]
buckets)
  (Histogram, IO [SampleGroup]) -> IO (Histogram, IO [SampleGroup])
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 -> Bucket
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 Bucket Int
histCountsPerBucket :: !(Map.Map Bucket Int)
} deriving (Int -> BucketCounts -> ShowS
[BucketCounts] -> ShowS
BucketCounts -> String
(Int -> BucketCounts -> ShowS)
-> (BucketCounts -> String)
-> ([BucketCounts] -> ShowS)
-> Show BucketCounts
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BucketCounts] -> ShowS
$cshowList :: [BucketCounts] -> ShowS
show :: BucketCounts -> String
$cshow :: BucketCounts -> String
showsPrec :: Int -> BucketCounts -> ShowS
$cshowsPrec :: Int -> BucketCounts -> ShowS
Show, BucketCounts -> BucketCounts -> Bool
(BucketCounts -> BucketCounts -> Bool)
-> (BucketCounts -> BucketCounts -> Bool) -> Eq BucketCounts
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
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
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
$cp1Ord :: Eq BucketCounts
Ord)

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

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

-- | Transform the contents of a histogram.
withHistogram :: MonadMonitor m
              => Histogram -> (BucketCounts -> BucketCounts) -> m ()
withHistogram :: 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 :: Histogram -> m (Map Bucket Int)
getHistogram (MkHistogram TVar BucketCounts
bucketsTVar) =
    IO (Map Bucket Int) -> m (Map Bucket Int)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map Bucket Int) -> m (Map Bucket Int))
-> IO (Map Bucket Int) -> m (Map Bucket Int)
forall a b. (a -> b) -> a -> b
$ BucketCounts -> Map Bucket Int
histCountsPerBucket (BucketCounts -> Map Bucket Int)
-> IO BucketCounts -> IO (Map Bucket 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 :: Bucket -> BucketCounts -> BucketCounts
insert Bucket
value BucketCounts { histTotal :: BucketCounts -> Bucket
histTotal = Bucket
total, histCount :: BucketCounts -> Int
histCount = Int
count, histCountsPerBucket :: BucketCounts -> Map Bucket Int
histCountsPerBucket = Map Bucket Int
counts } =
    Bucket -> Int -> Map Bucket Int -> BucketCounts
BucketCounts (Bucket
total Bucket -> Bucket -> Bucket
forall a. Num a => a -> a -> a
+ Bucket
value) (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Map Bucket Int
incCounts
    where
        incCounts :: Map Bucket Int
incCounts =
            case Bucket -> Map Bucket Int -> Maybe (Bucket, Int)
forall k v. Ord k => k -> Map k v -> Maybe (k, v)
Map.lookupGE Bucket
value Map Bucket Int
counts of
                Maybe (Bucket, Int)
Nothing -> Map Bucket Int
counts
                Just (Bucket
upperBound, Int
_) -> (Int -> Int) -> Bucket -> Map Bucket Int -> Map Bucket 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) Bucket
upperBound Map Bucket 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 Bucket
total Int
count Map Bucket 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") [] (Bucket -> ByteString
forall s. Show s => s -> ByteString
bsShow Bucket
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 = ((Bucket, Int) -> Sample) -> [(Bucket, Int)] -> [Sample]
forall a b. (a -> b) -> [a] -> [b]
map (Bucket, Int) -> Sample
forall a s. (RealFloat a, Show s) => (a, s) -> Sample
toSample ([(Bucket, Int)] -> [(Bucket, Int)]
forall b a. Num b => [(a, b)] -> [(a, b)]
cumulativeSum (Map Bucket Int -> [(Bucket, Int)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map Bucket Int
counts))
    [SampleGroup] -> STM [SampleGroup]
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 = String -> 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 String
"")

        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 :: s -> ByteString
bsShow = String -> ByteString
BS.fromString (String -> ByteString) -> (s -> String) -> s -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> String
forall a. Show a => a -> String
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 :: [Bucket]
defaultBuckets = [Bucket
0.005, Bucket
0.01, Bucket
0.025, Bucket
0.05, Bucket
0.1, Bucket
0.25, Bucket
0.5, Bucket
1, Bucket
2.5, Bucket
5, Bucket
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 :: Bucket -> Bucket -> Int -> [Bucket]
linearBuckets Bucket
start Bucket
width Int
count
    | Int
count Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = String -> [Bucket]
forall a. HasCallStack => String -> a
error (String
"Must provide a positive number of linear buckets, got: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
count)
    | Bool
otherwise = Int -> [Bucket] -> [Bucket]
forall a. Int -> [a] -> [a]
take Int
count ((Bucket -> Bucket) -> Bucket -> [Bucket]
forall a. (a -> a) -> a -> [a]
iterate (Bucket
widthBucket -> Bucket -> Bucket
forall a. Num a => a -> a -> a
+) Bucket
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 :: Bucket -> Bucket -> Int -> [Bucket]
exponentialBuckets Bucket
start Bucket
factor Int
count
    | Int
count Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = String -> [Bucket]
forall a. HasCallStack => String -> a
error (String
"Must provide a positive number of exponential buckets, got: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
count)
    | Bucket
factor Bucket -> Bucket -> Bool
forall a. Ord a => a -> a -> Bool
<= Bucket
1 = String -> [Bucket]
forall a. HasCallStack => String -> a
error (String
"Exponential buckets must have factor greater than 1 to ensure upper bounds are monotonically increasing, got: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Bucket -> String
forall a. Show a => a -> String
show Bucket
factor)
    | Bucket
start Bucket -> Bucket -> Bool
forall a. Ord a => a -> a -> Bool
<= Bucket
0 = String -> [Bucket]
forall a. HasCallStack => String -> a
error (String
"Exponential buckets must have positive number for start bucket to ensure upper bounds are monotonically increasing, got: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Bucket -> String
forall a. Show a => a -> String
show Bucket
start)
    | Bool
otherwise = Int -> [Bucket] -> [Bucket]
forall a. Int -> [a] -> [a]
take Int
count ((Bucket -> Bucket) -> Bucket -> [Bucket]
forall a. (a -> a) -> a -> [a]
iterate (Bucket
factorBucket -> Bucket -> Bucket
forall a. Num a => a -> a -> a
*) Bucket
start)