module Prometheus.Metric.Histogram (
Histogram
, 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 qualified Data.ByteString.UTF8 as BS
import qualified Data.Map.Strict as Map
import Numeric (showFFloat)
newtype Histogram = MkHistogram (STM.TVar BucketCounts)
histogram :: Info -> [Bucket] -> IO (Metric Histogram)
histogram info buckets = do
countsTVar <- STM.newTVarIO (emptyCounts buckets)
return Metric {
handle = MkHistogram countsTVar
, collect = collectHistogram info countsTVar
}
type Bucket = Double
data BucketCounts = BucketCounts {
histTotal :: !Double
, histCount :: !Int
, histCountsPerBucket :: Map.Map Bucket Int
} deriving (Show, Eq, Ord)
emptyCounts :: [Bucket] -> BucketCounts
emptyCounts buckets
| isStrictlyIncreasing buckets = BucketCounts 0 0 $ Map.fromList (zip buckets (repeat 0))
| otherwise = error ("Histogram buckets must be in increasing order, got: " ++ show buckets)
where
isStrictlyIncreasing xs = and (zipWith (<) xs (tail xs))
instance Observer Histogram where
observe v h = withHistogram h (insert v)
withHistogram :: MonadMonitor m
=> Metric Histogram -> (BucketCounts -> BucketCounts) -> m ()
withHistogram Metric {handle = MkHistogram bucketCounts} f =
doIO $ STM.atomically $ STM.modifyTVar' bucketCounts f
getHistogram :: Metric Histogram -> IO (Map.Map Bucket Int)
getHistogram Metric {handle = MkHistogram bucketsTVar} =
histCountsPerBucket <$> STM.atomically (STM.readTVar bucketsTVar)
insert :: Double -> BucketCounts -> BucketCounts
insert value BucketCounts { histTotal = total, histCount = count, histCountsPerBucket = counts } =
BucketCounts (total + value) (count + 1) incCounts
where
incCounts =
case Map.lookupGE value counts of
Nothing -> counts
Just (upperBound, _) -> Map.adjust (+1) upperBound counts
collectHistogram :: Info -> STM.TVar BucketCounts -> IO [SampleGroup]
collectHistogram info bucketCounts = STM.atomically $ do
BucketCounts total count counts <- STM.readTVar bucketCounts
let sumSample = Sample (name ++ "_sum") [] (bsShow total)
let countSample = Sample (name ++ "_count") [] (bsShow count)
let infSample = Sample name [(bucketLabel, "+Inf")] (bsShow count)
let samples = map toSample (cumulativeSum (Map.toAscList counts))
return [SampleGroup info HistogramType $ samples ++ [infSample, sumSample, countSample]]
where
toSample (upperBound, count') =
Sample name [(bucketLabel, formatFloat upperBound)] $ bsShow count'
name = metricName info
formatFloat x = showFFloat Nothing x ""
cumulativeSum xs = zip (map fst xs) (scanl1 (+) (map snd xs))
bsShow :: Show s => s -> BS.ByteString
bsShow = BS.fromString . show
bucketLabel :: String
bucketLabel = "le"
defaultBuckets :: [Double]
defaultBuckets = [0.005, 0.01, 0.025, 0.05, 0.1, 0.25, 0.5, 1, 2.5, 5, 10]
linearBuckets :: Bucket -> Double -> Int -> [Bucket]
linearBuckets start width count
| count <= 0 = error ("Must provide a positive number of linear buckets, got: " ++ show count)
| otherwise = take count (iterate (width+) start)
exponentialBuckets :: Bucket -> Double -> Int -> [Bucket]
exponentialBuckets start factor count
| count <= 0 = error ("Must provide a positive number of exponential buckets, got: " ++ show count)
| factor <= 1 = error ("Exponential buckets must have factor greater than 1 to ensure upper bounds are monotonically increasing, got: " ++ show factor)
| start <= 0 = error ("Exponential buckets must have positive number for start bucket to ensure upper bounds are monotonically increasing, got: " ++ show start)
| otherwise = take count (iterate (factor*) start)