{-# language BangPatterns #-}
{-# language OverloadedStrings #-}
module Prometheus.Metric.Histogram (
Histogram
, Bucket
, histogram
, defaultBuckets
, exponentialBuckets
, linearBuckets
, 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)
newtype Histogram = MkHistogram (STM.TVar BucketCounts)
instance NFData Histogram where
rnf :: Histogram -> ()
rnf (MkHistogram TVar BucketCounts
a) = TVar BucketCounts -> () -> ()
seq TVar BucketCounts
a ()
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)
type Bucket = Double
data BucketCounts = BucketCounts {
BucketCounts -> Bucket
histTotal :: !Double
, BucketCounts -> Int
histCount :: !Int
, 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
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)
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
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)
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
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
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
bucketLabel :: Text
bucketLabel :: Text
bucketLabel = Text
"le"
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]
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)
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)