From 301749fbbfe33c4bc742d55219540da522921b1e Mon Sep 17 00:00:00 2001 From: Maximilian Tagher Date: Sat, 17 May 2025 12:43:12 -0700 Subject: [PATCH 01/12] Add exemplar support --- prometheus-client/src/Prometheus.hs | 1 + .../src/Prometheus/Export/Text.hs | 13 +++-- prometheus-client/src/Prometheus/Label.hs | 8 +++ prometheus-client/src/Prometheus/Metric.hs | 6 +-- .../src/Prometheus/Metric/Counter.hs | 2 +- .../src/Prometheus/Metric/Gauge.hs | 2 +- .../src/Prometheus/Metric/Histogram.hs | 54 ++++++++++++++----- .../src/Prometheus/Metric/Summary.hs | 8 +-- .../src/Prometheus/Metric/Vector.hs | 4 +- .../tests/Prometheus/Export/TextSpec.hs | 24 +++++++++ 10 files changed, 94 insertions(+), 28 deletions(-) diff --git a/prometheus-client/src/Prometheus.hs b/prometheus-client/src/Prometheus.hs index 654d4ed..4b5665a 100644 --- a/prometheus-client/src/Prometheus.hs +++ b/prometheus-client/src/Prometheus.hs @@ -123,6 +123,7 @@ module Prometheus ( , exponentialBuckets , linearBuckets , getHistogram +, observeWithExemplar -- ** Vector -- diff --git a/prometheus-client/src/Prometheus/Export/Text.hs b/prometheus-client/src/Prometheus/Export/Text.hs index 4cb1019..52a23da 100644 --- a/prometheus-client/src/Prometheus/Export/Text.hs +++ b/prometheus-client/src/Prometheus/Export/Text.hs @@ -63,17 +63,22 @@ exportSamples samples = mconcat [ exportSample s <> Build.charUtf8 '\n' | s <- samples ] exportSample :: Sample -> Build.Builder -exportSample (Sample name labels value) = +exportSample (Sample name labels value exemplarLabelPairs) = Build.byteString (T.encodeUtf8 name) - <> (case labels of + <> buildLabelPairs labels + <> Build.charUtf8 ' ' + <> Build.byteString value + <> case exemplarLabelPairs of + [] -> mempty + xs -> (Build.byteString " # ") <> buildLabelPairs exemplarLabelPairs + + where buildLabelPairs labelPairs = (case labelPairs of [] -> mempty l:ls -> Build.charUtf8 '{' <> exportLabel l <> mconcat [ Build.charUtf8 ',' <> exportLabel l' | l' <- ls ] <> Build.charUtf8 '}') - <> Build.charUtf8 ' ' - <> Build.byteString value exportLabel :: (Text, Text) -> Build.Builder exportLabel (key, value) = diff --git a/prometheus-client/src/Prometheus/Label.hs b/prometheus-client/src/Prometheus/Label.hs index 4067e21..0662f58 100644 --- a/prometheus-client/src/Prometheus/Label.hs +++ b/prometheus-client/src/Prometheus/Label.hs @@ -14,6 +14,8 @@ module Prometheus.Label ( , Label7 , Label8 , Label9 +, traceLabel +, traceAndSpanLabels ) where import Data.Text @@ -88,3 +90,9 @@ instance (a ~ Text, b ~ a, c ~ a, d ~ a, e ~ a, f ~ a, g ~ a, h ~ a, i ~ a) => L (v1, v2, v3, v4, v5, v6, v7, v8, v9) = [(k1, v1), (k2, v2), (k3, v3), (k4, v4), (k5, v5), (k6, v6), (k7, v7), (k8, v8), (k9, v9)] + +traceLabel :: Text -> LabelPairs +traceLabel t = [("trace_id", t)] + +traceAndSpanLabels :: Text -> Text -> LabelPairs +traceAndSpanLabels t s = [("trace_id", t), ("span_id", s)] diff --git a/prometheus-client/src/Prometheus/Metric.hs b/prometheus-client/src/Prometheus/Metric.hs index f3cbfbc..972092f 100644 --- a/prometheus-client/src/Prometheus/Metric.hs +++ b/prometheus-client/src/Prometheus/Metric.hs @@ -32,9 +32,9 @@ instance Show SampleType where show UntypedType = "untyped" -- | A single value recorded at a moment in time. The sample type contains the --- name of the sample, a list of labels and their values, and the value encoded --- as a ByteString. -data Sample = Sample Text LabelPairs BS.ByteString +-- name of the sample, a list of labels and their values, the value encoded +-- as a ByteString, and an exemplar (histogram only). +data Sample = Sample Text LabelPairs BS.ByteString LabelPairs deriving (Show) -- | A Sample group is a list of samples that is tagged with meta data diff --git a/prometheus-client/src/Prometheus/Metric/Counter.hs b/prometheus-client/src/Prometheus/Metric/Counter.hs index 239a2e9..03fac26 100644 --- a/prometheus-client/src/Prometheus/Metric/Counter.hs +++ b/prometheus-client/src/Prometheus/Metric/Counter.hs @@ -77,7 +77,7 @@ getCounter (MkCounter ioref) = liftIO $ IORef.readIORef ioref collectCounter :: Info -> IORef.IORef Double -> IO [SampleGroup] collectCounter info c = do value <- IORef.readIORef c - let sample = Sample (metricName info) [] (BS.fromString $ show value) + let sample = Sample (metricName info) [] (BS.fromString $ show value) [] return [SampleGroup info CounterType [sample]] -- | Count the amount of times an action throws any synchronous exception. diff --git a/prometheus-client/src/Prometheus/Metric/Gauge.hs b/prometheus-client/src/Prometheus/Metric/Gauge.hs index c0fd80f..85e01fb 100644 --- a/prometheus-client/src/Prometheus/Metric/Gauge.hs +++ b/prometheus-client/src/Prometheus/Metric/Gauge.hs @@ -77,5 +77,5 @@ setGaugeToDuration metric io = do collectGauge :: Info -> IORef.IORef Double -> IO [SampleGroup] collectGauge info c = do value <- IORef.readIORef c - let sample = Sample (metricName info) [] (BS.fromString $ show value) + let sample = Sample (metricName info) [] (BS.fromString $ show value) [] return [SampleGroup info GaugeType [sample]] diff --git a/prometheus-client/src/Prometheus/Metric/Histogram.hs b/prometheus-client/src/Prometheus/Metric/Histogram.hs index e99da74..3c1d861 100644 --- a/prometheus-client/src/Prometheus/Metric/Histogram.hs +++ b/prometheus-client/src/Prometheus/Metric/Histogram.hs @@ -1,5 +1,6 @@ {-# language BangPatterns #-} {-# language OverloadedStrings #-} +{-# language ScopedTypeVariables #-} module Prometheus.Metric.Histogram ( Histogram @@ -8,15 +9,18 @@ module Prometheus.Metric.Histogram ( , defaultBuckets , exponentialBuckets , linearBuckets +, observeWithExemplar -- * Exported for testing , BucketCounts(..) , insert +, insertWithExemplar , emptyCounts , getHistogram ) where import Prometheus.Info +import Prometheus.Label import Prometheus.Metric import Prometheus.Metric.Observer import Prometheus.MonadMonitor @@ -61,11 +65,12 @@ data BucketCounts = BucketCounts { -- value is the number of observations less-than-or-equal-to -- that upper bound, but greater than the next lowest upper bound. , histCountsPerBucket :: !(Map.Map Bucket Int) +, histBucketLabels :: !(Map.Map Bucket LabelPairs) } deriving (Show, Eq, Ord) emptyCounts :: [Bucket] -> BucketCounts emptyCounts buckets - | isStrictlyIncreasing buckets = BucketCounts 0 0 $ Map.fromList (zip buckets (repeat 0)) + | isStrictlyIncreasing buckets = BucketCounts 0 0 (Map.fromList (zip buckets (repeat 0))) (Map.fromList (zip buckets (repeat []))) | otherwise = error ("Histogram buckets must be in increasing order, got: " ++ show buckets) where isStrictlyIncreasing xs = and (zipWith (<) xs (tail xs)) @@ -74,6 +79,18 @@ instance Observer Histogram where -- | Add a new observation to a histogram metric. observe h v = withHistogram h (insert v) +-- | Observe that a particular floating point value has occurred. +-- For example, observe that this request took 0.23s. +-- +-- In addition, tracks a set of key-value pairs called an [exemplar](https://grafana.com/docs/grafana/latest/fundamentals/exemplars/) +-- which are used to correlate time series data with traces. +-- +-- Typically the values tracked are "trace_id" and "span_id". +-- +-- This feature is experimental and must be [enabled on the Prometheus server](https://prometheus.io/docs/prometheus/latest/feature_flags/). +observeWithExemplar :: Histogram -> Double -> LabelPairs -> IO () +observeWithExemplar h v lp = withHistogram h (insertWithExemplar v lp) + -- | Transform the contents of a histogram. withHistogram :: MonadMonitor m => Histogram -> (BucketCounts -> BucketCounts) -> m () @@ -87,28 +104,39 @@ getHistogram :: MonadIO m => Histogram -> m (Map.Map Bucket Int) getHistogram (MkHistogram bucketsTVar) = liftIO $ histCountsPerBucket <$> STM.atomically (STM.readTVar bucketsTVar) + -- | Record an observation. 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 +insert value bucketCounts = insertWithExemplar value [] bucketCounts + +insertWithExemplar :: Double -> LabelPairs -> BucketCounts -> BucketCounts +insertWithExemplar value newLabelPairs BucketCounts { histTotal = total, histCount = count, histCountsPerBucket = counts, histBucketLabels = existingLabelMap } = + let updatedValues = case Map.lookupGE value counts of Nothing -> counts Just (upperBound, _) -> Map.adjust (+1) upperBound counts + updatedLabels = case newLabelPairs of + [] -> existingLabelMap + _xs -> case Map.lookupGE value counts of + Nothing -> existingLabelMap + Just (upperBound, _) -> Map.insert upperBound newLabelPairs existingLabelMap + + in BucketCounts (total + value) (count + 1) updatedValues updatedLabels + -- | Collect the current state of a histogram. 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 <> "_bucket") [(bucketLabel, "+Inf")] (bsShow count) - let samples = map toSample (cumulativeSum (Map.toAscList counts)) + BucketCounts total count counts labels <- STM.readTVar bucketCounts + let sumSample :: Sample = Sample (name <> "_sum") [] (bsShow total) [] + let countSample = Sample (name <> "_count") [] (bsShow count) [] + let infSample = Sample (name <> "_bucket") [(bucketLabel, "+Inf")] (bsShow count) [] + let upperBoundAndCount = (cumulativeSum (Map.toAscList counts)) + exemplarLabelPairs = map snd (Map.toAscList labels) + samples = map toSample (zip upperBoundAndCount exemplarLabelPairs) return [SampleGroup info HistogramType $ samples ++ [infSample, sumSample, countSample]] where - toSample (upperBound, count') = - Sample (name <> "_bucket") [(bucketLabel, formatFloat upperBound)] $ bsShow count' + toSample ((upperBound, count'), labelPairs) = + Sample (name <> "_bucket") [(bucketLabel, formatFloat upperBound)] (bsShow count') labelPairs name = metricName info -- We don't particularly want scientific notation, so force regular diff --git a/prometheus-client/src/Prometheus/Metric/Summary.hs b/prometheus-client/src/Prometheus/Metric/Summary.hs index dcc5b5d..320d3f0 100644 --- a/prometheus-client/src/Prometheus/Metric/Summary.hs +++ b/prometheus-client/src/Prometheus/Metric/Summary.hs @@ -93,8 +93,8 @@ collectSummary info (MkSummary sketchVar quantiles_) = withMVar sketchVar $ \ske count_ <- ReqSketch.count sketch estimatedQuantileValues <- forM quantiles_ $ \qv -> (,) <$> pure (fst qv) <*> ReqSketch.quantile sketch (toDouble $ fst qv) - let sumSample = Sample (metricName info <> "_sum") [] (bsShow itemSum) - let countSample = Sample (metricName info <> "_count") [] (bsShow count_) + let sumSample = Sample (metricName info <> "_sum") [] (bsShow itemSum) [] + let countSample = Sample (metricName info <> "_count") [] (bsShow count_) [] return [SampleGroup info SummaryType $ map toSample estimatedQuantileValues ++ [sumSample, countSample]] where bsShow :: Show s => s -> BS.ByteString @@ -102,8 +102,8 @@ collectSummary info (MkSummary sketchVar quantiles_) = withMVar sketchVar $ \ske toSample :: (Rational, Double) -> Sample toSample (q, estimatedValue) = - Sample (metricName info) [("quantile", T.pack . show $ toDouble q)] $ - bsShow estimatedValue + Sample (metricName info) [("quantile", T.pack . show $ toDouble q)] + (bsShow estimatedValue) [] toDouble :: Rational -> Double toDouble = fromRational diff --git a/prometheus-client/src/Prometheus/Metric/Vector.hs b/prometheus-client/src/Prometheus/Metric/Vector.hs index 117cc84..2e21059 100644 --- a/prometheus-client/src/Prometheus/Metric/Vector.hs +++ b/prometheus-client/src/Prometheus/Metric/Vector.hs @@ -67,8 +67,8 @@ collectVector keys ioref = do adjustSamples labels (SampleGroup info ty samples) = SampleGroup info ty (map (prependLabels labels) samples) - prependLabels l (Sample name labels value) = - Sample name (labelPairs keys l ++ labels) value + prependLabels l (Sample name labels value exemplarLabelPairs) = + Sample name (labelPairs keys l ++ labels) value exemplarLabelPairs joinSamples [] = [] joinSamples s@(SampleGroup i t _:_) = [SampleGroup i t (extract s)] diff --git a/prometheus-client/tests/Prometheus/Export/TextSpec.hs b/prometheus-client/tests/Prometheus/Export/TextSpec.hs index ae719d0..62911ee 100644 --- a/prometheus-client/tests/Prometheus/Export/TextSpec.hs +++ b/prometheus-client/tests/Prometheus/Export/TextSpec.hs @@ -70,6 +70,30 @@ spec = before_ unregisterAll $ after_ unregisterAll $ , "metric_sum 3.0" , "metric_count 3" ]) + it "renders histograms with exemplars" $ do + m <- register $ histogram (Info "metric" "help") defaultBuckets + observeWithExemplar m 1.0 [("trace_id", "1")] + observe m 1.0 + observe m 1.0 + result <- exportMetricsAsText + result `shouldBe` LT.encodeUtf8 (LT.pack $ unlines [ + "# HELP metric help" + , "# TYPE metric histogram" + , "metric_bucket{le=\"0.005\"} 0" + , "metric_bucket{le=\"0.01\"} 0" + , "metric_bucket{le=\"0.025\"} 0" + , "metric_bucket{le=\"0.05\"} 0" + , "metric_bucket{le=\"0.1\"} 0" + , "metric_bucket{le=\"0.25\"} 0" + , "metric_bucket{le=\"0.5\"} 0" + , "metric_bucket{le=\"1.0\"} 3 # {trace_id=\"1\"}" + , "metric_bucket{le=\"2.5\"} 3" + , "metric_bucket{le=\"5.0\"} 3" + , "metric_bucket{le=\"10.0\"} 3" + , "metric_bucket{le=\"+Inf\"} 3" + , "metric_sum 3.0" + , "metric_count 3" + ]) it "renders vectors" $ do m <- register $ vector ("handler", "method") $ counter (Info "test_counter" "help string") From 80c60ee4d54dff9368906e88f1558a5a21a79067 Mon Sep 17 00:00:00 2001 From: Maximilian Tagher Date: Sat, 17 May 2025 13:11:48 -0700 Subject: [PATCH 02/12] remove label helpers --- prometheus-client/src/Prometheus/Label.hs | 8 -------- prometheus-client/src/Prometheus/Metric/Histogram.hs | 6 ++++-- prometheus-client/tests/Prometheus/Export/TextSpec.hs | 4 ++-- 3 files changed, 6 insertions(+), 12 deletions(-) diff --git a/prometheus-client/src/Prometheus/Label.hs b/prometheus-client/src/Prometheus/Label.hs index 0662f58..4067e21 100644 --- a/prometheus-client/src/Prometheus/Label.hs +++ b/prometheus-client/src/Prometheus/Label.hs @@ -14,8 +14,6 @@ module Prometheus.Label ( , Label7 , Label8 , Label9 -, traceLabel -, traceAndSpanLabels ) where import Data.Text @@ -90,9 +88,3 @@ instance (a ~ Text, b ~ a, c ~ a, d ~ a, e ~ a, f ~ a, g ~ a, h ~ a, i ~ a) => L (v1, v2, v3, v4, v5, v6, v7, v8, v9) = [(k1, v1), (k2, v2), (k3, v3), (k4, v4), (k5, v5), (k6, v6), (k7, v7), (k8, v8), (k9, v9)] - -traceLabel :: Text -> LabelPairs -traceLabel t = [("trace_id", t)] - -traceAndSpanLabels :: Text -> Text -> LabelPairs -traceAndSpanLabels t s = [("trace_id", t), ("span_id", s)] diff --git a/prometheus-client/src/Prometheus/Metric/Histogram.hs b/prometheus-client/src/Prometheus/Metric/Histogram.hs index 3c1d861..2f792ff 100644 --- a/prometheus-client/src/Prometheus/Metric/Histogram.hs +++ b/prometheus-client/src/Prometheus/Metric/Histogram.hs @@ -88,6 +88,8 @@ instance Observer Histogram where -- Typically the values tracked are "trace_id" and "span_id". -- -- This feature is experimental and must be [enabled on the Prometheus server](https://prometheus.io/docs/prometheus/latest/feature_flags/). +-- +-- > withLabel incomingHttpRequestSeconds "Signup_POST" (`observeWithExemplar` 1.23 [("trace_id", "12345"), ("span_id", "67890")]) observeWithExemplar :: Histogram -> Double -> LabelPairs -> IO () observeWithExemplar h v lp = withHistogram h (insertWithExemplar v lp) @@ -135,8 +137,8 @@ collectHistogram info bucketCounts = STM.atomically $ do samples = map toSample (zip upperBoundAndCount exemplarLabelPairs) return [SampleGroup info HistogramType $ samples ++ [infSample, sumSample, countSample]] where - toSample ((upperBound, count'), labelPairs) = - Sample (name <> "_bucket") [(bucketLabel, formatFloat upperBound)] (bsShow count') labelPairs + toSample ((upperBound, count'), exemplarLabelPairs) = + Sample (name <> "_bucket") [(bucketLabel, formatFloat upperBound)] (bsShow count') exemplarLabelPairs name = metricName info -- We don't particularly want scientific notation, so force regular diff --git a/prometheus-client/tests/Prometheus/Export/TextSpec.hs b/prometheus-client/tests/Prometheus/Export/TextSpec.hs index 62911ee..60eed2c 100644 --- a/prometheus-client/tests/Prometheus/Export/TextSpec.hs +++ b/prometheus-client/tests/Prometheus/Export/TextSpec.hs @@ -73,7 +73,7 @@ spec = before_ unregisterAll $ after_ unregisterAll $ it "renders histograms with exemplars" $ do m <- register $ histogram (Info "metric" "help") defaultBuckets observeWithExemplar m 1.0 [("trace_id", "1")] - observe m 1.0 + observeWithExemplar m 1.0 [("trace_id", "2")] observe m 1.0 result <- exportMetricsAsText result `shouldBe` LT.encodeUtf8 (LT.pack $ unlines [ @@ -86,7 +86,7 @@ spec = before_ unregisterAll $ after_ unregisterAll $ , "metric_bucket{le=\"0.1\"} 0" , "metric_bucket{le=\"0.25\"} 0" , "metric_bucket{le=\"0.5\"} 0" - , "metric_bucket{le=\"1.0\"} 3 # {trace_id=\"1\"}" + , "metric_bucket{le=\"1.0\"} 3 # {trace_id=\"2\"}" , "metric_bucket{le=\"2.5\"} 3" , "metric_bucket{le=\"5.0\"} 3" , "metric_bucket{le=\"10.0\"} 3" From 598fe1c0c5b232cc055f8ac83fcbccb40ecbd624 Mon Sep 17 00:00:00 2001 From: Maximilian Tagher Date: Sat, 17 May 2025 13:13:13 -0700 Subject: [PATCH 03/12] .. --- prometheus-client/src/Prometheus/Metric/Histogram.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/prometheus-client/src/Prometheus/Metric/Histogram.hs b/prometheus-client/src/Prometheus/Metric/Histogram.hs index 2f792ff..ebb6477 100644 --- a/prometheus-client/src/Prometheus/Metric/Histogram.hs +++ b/prometheus-client/src/Prometheus/Metric/Histogram.hs @@ -1,6 +1,5 @@ {-# language BangPatterns #-} {-# language OverloadedStrings #-} -{-# language ScopedTypeVariables #-} module Prometheus.Metric.Histogram ( Histogram @@ -106,7 +105,6 @@ getHistogram :: MonadIO m => Histogram -> m (Map.Map Bucket Int) getHistogram (MkHistogram bucketsTVar) = liftIO $ histCountsPerBucket <$> STM.atomically (STM.readTVar bucketsTVar) - -- | Record an observation. insert :: Double -> BucketCounts -> BucketCounts insert value bucketCounts = insertWithExemplar value [] bucketCounts @@ -129,7 +127,7 @@ insertWithExemplar value newLabelPairs BucketCounts { histTotal = total, histCou collectHistogram :: Info -> STM.TVar BucketCounts -> IO [SampleGroup] collectHistogram info bucketCounts = STM.atomically $ do BucketCounts total count counts labels <- STM.readTVar bucketCounts - let sumSample :: Sample = Sample (name <> "_sum") [] (bsShow total) [] + let sumSample = Sample (name <> "_sum") [] (bsShow total) [] let countSample = Sample (name <> "_count") [] (bsShow count) [] let infSample = Sample (name <> "_bucket") [(bucketLabel, "+Inf")] (bsShow count) [] let upperBoundAndCount = (cumulativeSum (Map.toAscList counts)) From 860feadc6087414399b81ea6a2c9b6ace0453522 Mon Sep 17 00:00:00 2001 From: Maximilian Tagher Date: Sat, 17 May 2025 13:17:52 -0700 Subject: [PATCH 04/12] cleanup --- prometheus-client/src/Prometheus/Export/Text.hs | 10 +++++----- prometheus-client/src/Prometheus/Metric/Histogram.hs | 2 +- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/prometheus-client/src/Prometheus/Export/Text.hs b/prometheus-client/src/Prometheus/Export/Text.hs index 52a23da..7d2c888 100644 --- a/prometheus-client/src/Prometheus/Export/Text.hs +++ b/prometheus-client/src/Prometheus/Export/Text.hs @@ -68,17 +68,17 @@ exportSample (Sample name labels value exemplarLabelPairs) = <> buildLabelPairs labels <> Build.charUtf8 ' ' <> Build.byteString value - <> case exemplarLabelPairs of - [] -> mempty - xs -> (Build.byteString " # ") <> buildLabelPairs exemplarLabelPairs + <> if null exemplarLabelPairs + then mempty + else Build.byteString " # " <> buildLabelPairs exemplarLabelPairs - where buildLabelPairs labelPairs = (case labelPairs of + where buildLabelPairs labelPairs = case labelPairs of [] -> mempty l:ls -> Build.charUtf8 '{' <> exportLabel l <> mconcat [ Build.charUtf8 ',' <> exportLabel l' | l' <- ls ] - <> Build.charUtf8 '}') + <> Build.charUtf8 '}' exportLabel :: (Text, Text) -> Build.Builder exportLabel (key, value) = diff --git a/prometheus-client/src/Prometheus/Metric/Histogram.hs b/prometheus-client/src/Prometheus/Metric/Histogram.hs index ebb6477..2126aec 100644 --- a/prometheus-client/src/Prometheus/Metric/Histogram.hs +++ b/prometheus-client/src/Prometheus/Metric/Histogram.hs @@ -130,7 +130,7 @@ collectHistogram info bucketCounts = STM.atomically $ do let sumSample = Sample (name <> "_sum") [] (bsShow total) [] let countSample = Sample (name <> "_count") [] (bsShow count) [] let infSample = Sample (name <> "_bucket") [(bucketLabel, "+Inf")] (bsShow count) [] - let upperBoundAndCount = (cumulativeSum (Map.toAscList counts)) + let upperBoundAndCount = cumulativeSum (Map.toAscList counts) exemplarLabelPairs = map snd (Map.toAscList labels) samples = map toSample (zip upperBoundAndCount exemplarLabelPairs) return [SampleGroup info HistogramType $ samples ++ [infSample, sumSample, countSample]] From 6a45ea252fa52f3cf51e69647313d73d78a2e886 Mon Sep 17 00:00:00 2001 From: Maximilian Tagher Date: Sat, 17 May 2025 13:38:20 -0700 Subject: [PATCH 05/12] Fix other libraries --- prometheus-metrics-ghc/src/Prometheus/Metric/GHC.hs | 2 +- prometheus-proc/src/Prometheus/Metric/Proc.hs | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/prometheus-metrics-ghc/src/Prometheus/Metric/GHC.hs b/prometheus-metrics-ghc/src/Prometheus/Metric/GHC.hs index 1148b12..e6c34d0 100644 --- a/prometheus-metrics-ghc/src/Prometheus/Metric/GHC.hs +++ b/prometheus-metrics-ghc/src/Prometheus/Metric/GHC.hs @@ -350,4 +350,4 @@ showCollector :: Show a => Text -> Text -> SampleType -> a -> LabelPairs -> IO [ showCollector name help sampleType value labels = do let info = Info name help let valueBS = BS.fromString $ show value - return [SampleGroup info sampleType [Sample name labels valueBS]] + return [SampleGroup info sampleType [Sample name labels valueBS []]] diff --git a/prometheus-proc/src/Prometheus/Metric/Proc.hs b/prometheus-proc/src/Prometheus/Metric/Proc.hs index 7bf2553..fc37e65 100644 --- a/prometheus-proc/src/Prometheus/Metric/Proc.hs +++ b/prometheus-proc/src/Prometheus/Metric/Proc.hs @@ -172,6 +172,7 @@ metric metricName metricHelp metricType value = metricName [] ( fromString ( show value ) ) + [] ] From 0606d9e476325f97386b9deb7f17af87944d066d Mon Sep 17 00:00:00 2001 From: Maximilian Tagher Date: Sat, 17 May 2025 14:53:31 -0700 Subject: [PATCH 06/12] maybe fix doctest --- prometheus-client/src/Prometheus.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/prometheus-client/src/Prometheus.hs b/prometheus-client/src/Prometheus.hs index 4b5665a..d0092a9 100644 --- a/prometheus-client/src/Prometheus.hs +++ b/prometheus-client/src/Prometheus.hs @@ -201,7 +201,7 @@ module Prometheus ( -- >>> newtype CPUTime = MkCPUTime () -- >>> let info = Info "cpu_time" "The current CPU time" -- >>> let toValue = Data.ByteString.UTF8.fromString . show --- >>> let toSample = Sample "cpu_time" [] . toValue +-- >>> let toSample x = Sample "cpu_time" [] (toValue x) [] -- >>> let toSampleGroup = (:[]) . SampleGroup info GaugeType . (:[]) . toSample -- >>> let collectCPUTime = fmap toSampleGroup getCPUTime -- >>> let cpuTimeMetric = Metric (return (MkCPUTime (), collectCPUTime)) From e4cc113dc750fcd4ffb46a1e344b53d1d6f53c30 Mon Sep 17 00:00:00 2001 From: Maximilian Tagher Date: Sun, 18 May 2025 18:42:08 -0700 Subject: [PATCH 07/12] have example/ use openmetrics --- example/Main.hs | 2 +- prometheus-client/src/Prometheus.hs | 1 + .../src/Prometheus/Export/Text.hs | 28 ++++++++++++-- .../src/Network/Wai/Middleware/Prometheus.hs | 38 ++++++++++++++----- 4 files changed, 56 insertions(+), 13 deletions(-) diff --git a/example/Main.hs b/example/Main.hs index 73c060d..2434127 100644 --- a/example/Main.hs +++ b/example/Main.hs @@ -43,7 +43,7 @@ main = do -- Instrument the app with the prometheus middlware using the default -- `PrometheusSettings`. This will cause the app to dump the metrics when -- the /metrics endpoint is accessed. - run port (P.prometheus P.def app) + run port (P.prometheus P.def {P.prometheusExportFormat = P.OpenMetricsOneZeroZero} app) app :: Wai.Application app request respond = do diff --git a/prometheus-client/src/Prometheus.hs b/prometheus-client/src/Prometheus.hs index 654d4ed..ea70282 100644 --- a/prometheus-client/src/Prometheus.hs +++ b/prometheus-client/src/Prometheus.hs @@ -14,6 +14,7 @@ module Prometheus ( -- * Exporting , exportMetricsAsText +, exportMetricsAsOpenMetrics1 -- * Metrics -- diff --git a/prometheus-client/src/Prometheus/Export/Text.hs b/prometheus-client/src/Prometheus/Export/Text.hs index 4cb1019..1a1c3c6 100644 --- a/prometheus-client/src/Prometheus/Export/Text.hs +++ b/prometheus-client/src/Prometheus/Export/Text.hs @@ -2,6 +2,7 @@ module Prometheus.Export.Text ( exportMetricsAsText +, exportMetricsAsOpenMetrics1 ) where import Prometheus.Info @@ -39,10 +40,30 @@ import qualified Data.Text.Encoding as T exportMetricsAsText :: MonadIO m => m BS.ByteString exportMetricsAsText = do samples <- collectMetrics - return $ Build.toLazyByteString $ foldMap exportSampleGroup samples + return $ Build.toLazyByteString $ foldMap (exportSampleGroup TextZeroZeroFour) samples -exportSampleGroup :: SampleGroup -> Build.Builder -exportSampleGroup (SampleGroup info ty samples) = +-- | Export all registered metrics in the OpenMetrics 1.0.0 format. +-- +-- For the full specification of the format, see the official Prometheus +-- . +-- +-- Note, you MUST set the content-type header to: +-- @application/openmetrics-text; version=1.0.0; charset=utf-8@ +-- for this format. +-- +-- The OpenMetrics spec lists more features than Prometheus actually supports. +-- The only additional benefit of OpenMetrics when using this library is that +-- exemplars are supported. +exportMetricsAsOpenMetrics1 :: MonadIO m => m BS.ByteString +exportMetricsAsOpenMetrics1 = do + samples <- collectMetrics + return $ Build.toLazyByteString $ (foldMap (exportSampleGroup OpenMetricsOneZeroZero) samples) <> Build.byteString "# EOF\n" + +data ExportFormat = TextZeroZeroFour | OpenMetricsOneZeroZero + deriving (Show, Eq, Ord) + +exportSampleGroup :: ExportFormat -> SampleGroup -> Build.Builder +exportSampleGroup format (SampleGroup info ty samples) = if null samples then mempty else prefix <> exportedSamples @@ -55,6 +76,7 @@ exportSampleGroup (SampleGroup info ty samples) = , "# TYPE " <> name <> " " <> T.pack (show ty) ] escape '\n' = "\\n" + escape '"' = if format == OpenMetricsOneZeroZero then "\\\"" else "\"" escape '\\' = "\\\\" escape other = T.pack [other] diff --git a/wai-middleware-prometheus/src/Network/Wai/Middleware/Prometheus.hs b/wai-middleware-prometheus/src/Network/Wai/Middleware/Prometheus.hs index 34758d1..3f164f7 100644 --- a/wai-middleware-prometheus/src/Network/Wai/Middleware/Prometheus.hs +++ b/wai-middleware-prometheus/src/Network/Wai/Middleware/Prometheus.hs @@ -15,6 +15,8 @@ module Network.Wai.Middleware.Prometheus , instrumentIO , observeSeconds , metricsApp + , metricsAppWithFormat + , ExportFormat(..) ) where import qualified Data.Default as Default @@ -29,6 +31,12 @@ import qualified Network.Wai.Internal as Wai (Response(ResponseRaw)) import qualified Prometheus as Prom import System.Clock (Clock(..), TimeSpec, diffTimeSpec, getTime, toNanoSecs) +-- | What content type to export data in. +-- These formats are nearly identical; the only practical difference +-- is that OpenMetrics supports exemplars and requires this content-type header: +-- @application/openmetrics-text; version=1.0.0; charset=utf-8@ +data ExportFormat = PrometheusText | OpenMetricsOneZeroZero + deriving (Show, Eq, Ord) -- | Settings that control the behavior of the Prometheus middleware. data PrometheusSettings = PrometheusSettings { @@ -44,6 +52,8 @@ data PrometheusSettings = PrometheusSettings { -- ^ Whether the default instrumentation should be applied to the -- middleware that serves the metrics endpoint. The default value is -- True. + , prometheusExportFormat :: ExportFormat + -- ^ Which format to export metrics in. The default value is PrometheusText. } instance Default.Default PrometheusSettings where @@ -51,6 +61,7 @@ instance Default.Default PrometheusSettings where prometheusEndPoint = ["metrics"] , prometheusInstrumentApp = True , prometheusInstrumentPrometheus = True + , prometheusExportFormat = PrometheusText } {-# NOINLINE requestLatency #-} @@ -187,8 +198,8 @@ prometheus PrometheusSettings{..} app req respond = -- "prometheus" can be confused with actual prometheus. then if prometheusInstrumentPrometheus - then instrumentApp "prometheus" (const respondWithMetrics) req respond - else respondWithMetrics respond + then instrumentApp "prometheus" (const (respondWithMetrics prometheusExportFormat)) req respond + else respondWithMetrics prometheusExportFormat respond else if prometheusInstrumentApp then instrumentApp "app" app req respond @@ -196,14 +207,23 @@ prometheus PrometheusSettings{..} app req respond = -- | WAI Application that serves the Prometheus metrics page regardless of --- what the request is. +-- what the request is. Uses the Prometheus text format. metricsApp :: Wai.Application -metricsApp = const respondWithMetrics +metricsApp = const (respondWithMetrics PrometheusText) + +-- | WAI Application that serves the Prometheus metrics page regardless of +-- what the request is. +metricsAppWithFormat :: ExportFormat -> Wai.Application +metricsAppWithFormat format = const (respondWithMetrics format) -respondWithMetrics :: (Wai.Response -> IO Wai.ResponseReceived) +respondWithMetrics :: ExportFormat -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived -respondWithMetrics respond = do - metrics <- Prom.exportMetricsAsText - respond $ Wai.responseLBS HTTP.status200 headers metrics +respondWithMetrics format respond = do + metrics <- case format of + PrometheusText -> Prom.exportMetricsAsText + OpenMetricsOneZeroZero -> Prom.exportMetricsAsOpenMetrics1 + respond $ Wai.responseLBS HTTP.status200 [(HTTP.hContentType, contentType)] metrics where - headers = [(HTTP.hContentType, "text/plain; version=0.0.4")] + contentType = case format of + PrometheusText -> "text/plain; version=0.0.4" + OpenMetricsOneZeroZero -> "application/openmetrics-text; version=1.0.0; charset=utf-8" From 6ced0bba7a7e4c641735bb37d80eaa28b4b24c7e Mon Sep 17 00:00:00 2001 From: Maximilian Tagher Date: Sun, 18 May 2025 19:09:47 -0700 Subject: [PATCH 08/12] Fix exemplar format --- .../src/Prometheus/Export/Text.hs | 29 ++++++++--- prometheus-client/src/Prometheus/Metric.hs | 12 ++++- .../src/Prometheus/Metric/Counter.hs | 2 +- .../src/Prometheus/Metric/Gauge.hs | 2 +- .../src/Prometheus/Metric/Histogram.hs | 52 ++++++++++++------- .../src/Prometheus/Metric/Summary.hs | 6 +-- .../src/Prometheus/Metric/GHC.hs | 2 +- 7 files changed, 71 insertions(+), 34 deletions(-) diff --git a/prometheus-client/src/Prometheus/Export/Text.hs b/prometheus-client/src/Prometheus/Export/Text.hs index cb79db3..5928b75 100644 --- a/prometheus-client/src/Prometheus/Export/Text.hs +++ b/prometheus-client/src/Prometheus/Export/Text.hs @@ -17,7 +17,7 @@ import Data.Monoid ((<>), mempty, mconcat) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T - +import System.Clock -- $setup -- >>> :module +Prometheus @@ -85,16 +85,33 @@ exportSamples samples = mconcat [ exportSample s <> Build.charUtf8 '\n' | s <- samples ] exportSample :: Sample -> Build.Builder -exportSample (Sample name labels value exemplarLabelPairs) = +exportSample (Sample name labels value mExemplar) = Build.byteString (T.encodeUtf8 name) <> buildLabelPairs labels <> Build.charUtf8 ' ' <> Build.byteString value - <> if null exemplarLabelPairs - then mempty - else Build.byteString " # " <> buildLabelPairs exemplarLabelPairs + <> case mExemplar of + Nothing -> mempty + Just exemplar -> encodeExemplar exemplar + + where + encodeExemplar :: SampleExemplar -> Build.Builder + encodeExemplar (SampleExemplar labelPairs exemplarValue mTimestamp) = + Build.byteString " # " + <> buildLabelPairs labelPairs + <> Build.charUtf8 ' ' + <> Build.byteString exemplarValue + <> case mTimestamp of + Nothing -> mempty + Just timestamp -> Build.charUtf8 ' ' <> encodeTimespec timestamp + + encodeTimespec :: TimeSpec -> Build.Builder + encodeTimespec timespec = + Build.int64Dec (sec timespec) + <> Build.charUtf8 '.' + <> Build.int64Dec (nsec timespec) - where buildLabelPairs labelPairs = case labelPairs of + buildLabelPairs labelPairs = case labelPairs of [] -> mempty l:ls -> Build.charUtf8 '{' diff --git a/prometheus-client/src/Prometheus/Metric.hs b/prometheus-client/src/Prometheus/Metric.hs index 972092f..3914d9f 100644 --- a/prometheus-client/src/Prometheus/Metric.hs +++ b/prometheus-client/src/Prometheus/Metric.hs @@ -5,6 +5,7 @@ module Prometheus.Metric ( , Sample (..) , SampleGroup (..) , SampleType (..) +, SampleExemplar(..) ) where import Prometheus.Info @@ -13,6 +14,7 @@ import Prometheus.Label import Control.DeepSeq import qualified Data.ByteString as BS import Data.Text (Text) +import System.Clock -- | The type of a sample. This corresponds to the 5 types of metrics supported @@ -31,10 +33,16 @@ instance Show SampleType where show HistogramType = "histogram" show UntypedType = "untyped" +-- | A specific example for a metric. Contains key-value pairs for the sample +-- (e.g. a trace_id), the value of the sample encoded as a ByteString, +-- and an optional timestamp. +data SampleExemplar = SampleExemplar LabelPairs BS.ByteString (Maybe TimeSpec) + deriving (Show) + -- | A single value recorded at a moment in time. The sample type contains the -- name of the sample, a list of labels and their values, the value encoded --- as a ByteString, and an exemplar (histogram only). -data Sample = Sample Text LabelPairs BS.ByteString LabelPairs +-- as a ByteString, and an exemplar (counter and histogram only). +data Sample = Sample Text LabelPairs BS.ByteString (Maybe SampleExemplar) deriving (Show) -- | A Sample group is a list of samples that is tagged with meta data diff --git a/prometheus-client/src/Prometheus/Metric/Counter.hs b/prometheus-client/src/Prometheus/Metric/Counter.hs index 03fac26..38f93b8 100644 --- a/prometheus-client/src/Prometheus/Metric/Counter.hs +++ b/prometheus-client/src/Prometheus/Metric/Counter.hs @@ -77,7 +77,7 @@ getCounter (MkCounter ioref) = liftIO $ IORef.readIORef ioref collectCounter :: Info -> IORef.IORef Double -> IO [SampleGroup] collectCounter info c = do value <- IORef.readIORef c - let sample = Sample (metricName info) [] (BS.fromString $ show value) [] + let sample = Sample (metricName info) [] (BS.fromString $ show value) Nothing return [SampleGroup info CounterType [sample]] -- | Count the amount of times an action throws any synchronous exception. diff --git a/prometheus-client/src/Prometheus/Metric/Gauge.hs b/prometheus-client/src/Prometheus/Metric/Gauge.hs index 85e01fb..8f0db9a 100644 --- a/prometheus-client/src/Prometheus/Metric/Gauge.hs +++ b/prometheus-client/src/Prometheus/Metric/Gauge.hs @@ -77,5 +77,5 @@ setGaugeToDuration metric io = do collectGauge :: Info -> IORef.IORef Double -> IO [SampleGroup] collectGauge info c = do value <- IORef.readIORef c - let sample = Sample (metricName info) [] (BS.fromString $ show value) [] + let sample = Sample (metricName info) [] (BS.fromString $ show value) Nothing return [SampleGroup info GaugeType [sample]] diff --git a/prometheus-client/src/Prometheus/Metric/Histogram.hs b/prometheus-client/src/Prometheus/Metric/Histogram.hs index 2126aec..ae170d6 100644 --- a/prometheus-client/src/Prometheus/Metric/Histogram.hs +++ b/prometheus-client/src/Prometheus/Metric/Histogram.hs @@ -1,5 +1,6 @@ {-# language BangPatterns #-} {-# language OverloadedStrings #-} +{-# language RecordWildCards #-} module Prometheus.Metric.Histogram ( Histogram @@ -34,6 +35,7 @@ import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T import Numeric (showFFloat) +import System.Clock -- | A histogram. Counts the number of observations that fall within the -- specified buckets. @@ -54,6 +56,12 @@ histogram info buckets = Metric $ do -- | Upper-bound for a histogram bucket. type Bucket = Double +data HistogramExemplar = HistogramExemplar { + histExemplarLabelPairs :: LabelPairs +, histExemplarValue :: !Double +, histExemplarTimestamp :: !(Maybe TimeSpec) +} deriving (Show, Eq, Ord) + -- | Current state of a histogram. data BucketCounts = BucketCounts { -- | The sum of all the observations. @@ -64,12 +72,12 @@ data BucketCounts = BucketCounts { -- value is the number of observations less-than-or-equal-to -- that upper bound, but greater than the next lowest upper bound. , histCountsPerBucket :: !(Map.Map Bucket Int) -, histBucketLabels :: !(Map.Map Bucket LabelPairs) +, histBucketExemplars :: !(Map.Map Bucket (Maybe HistogramExemplar)) } deriving (Show, Eq, Ord) emptyCounts :: [Bucket] -> BucketCounts emptyCounts buckets - | isStrictlyIncreasing buckets = BucketCounts 0 0 (Map.fromList (zip buckets (repeat 0))) (Map.fromList (zip buckets (repeat []))) + | isStrictlyIncreasing buckets = BucketCounts 0 0 (Map.fromList (zip buckets (repeat 0))) (Map.fromList (zip buckets (repeat Nothing))) | otherwise = error ("Histogram buckets must be in increasing order, got: " ++ show buckets) where isStrictlyIncreasing xs = and (zipWith (<) xs (tail xs)) @@ -89,8 +97,8 @@ instance Observer Histogram where -- This feature is experimental and must be [enabled on the Prometheus server](https://prometheus.io/docs/prometheus/latest/feature_flags/). -- -- > withLabel incomingHttpRequestSeconds "Signup_POST" (`observeWithExemplar` 1.23 [("trace_id", "12345"), ("span_id", "67890")]) -observeWithExemplar :: Histogram -> Double -> LabelPairs -> IO () -observeWithExemplar h v lp = withHistogram h (insertWithExemplar v lp) +observeWithExemplar :: Histogram -> Double -> HistogramExemplar -> IO () +observeWithExemplar h v exemplar = withHistogram h (insertWithExemplar v (Just exemplar)) -- | Transform the contents of a histogram. withHistogram :: MonadMonitor m @@ -107,36 +115,36 @@ getHistogram (MkHistogram bucketsTVar) = -- | Record an observation. insert :: Double -> BucketCounts -> BucketCounts -insert value bucketCounts = insertWithExemplar value [] bucketCounts +insert value bucketCounts = insertWithExemplar value Nothing bucketCounts -insertWithExemplar :: Double -> LabelPairs -> BucketCounts -> BucketCounts -insertWithExemplar value newLabelPairs BucketCounts { histTotal = total, histCount = count, histCountsPerBucket = counts, histBucketLabels = existingLabelMap } = +insertWithExemplar :: Double -> (Maybe HistogramExemplar) -> BucketCounts -> BucketCounts +insertWithExemplar value mHistogramExemplar BucketCounts { histTotal = total, histCount = count, histCountsPerBucket = counts, histBucketExemplars = existingExemplarMap } = let updatedValues = case Map.lookupGE value counts of Nothing -> counts Just (upperBound, _) -> Map.adjust (+1) upperBound counts - updatedLabels = case newLabelPairs of - [] -> existingLabelMap - _xs -> case Map.lookupGE value counts of - Nothing -> existingLabelMap - Just (upperBound, _) -> Map.insert upperBound newLabelPairs existingLabelMap + updatedLabels = case mHistogramExemplar of + Nothing -> existingExemplarMap + Just newExemplar -> case Map.lookupGE value counts of + Nothing -> existingExemplarMap + Just (upperBound, _) -> Map.insert upperBound (Just newExemplar) existingExemplarMap in BucketCounts (total + value) (count + 1) updatedValues updatedLabels -- | Collect the current state of a histogram. collectHistogram :: Info -> STM.TVar BucketCounts -> IO [SampleGroup] collectHistogram info bucketCounts = STM.atomically $ do - BucketCounts total count counts labels <- STM.readTVar bucketCounts - let sumSample = Sample (name <> "_sum") [] (bsShow total) [] - let countSample = Sample (name <> "_count") [] (bsShow count) [] - let infSample = Sample (name <> "_bucket") [(bucketLabel, "+Inf")] (bsShow count) [] + BucketCounts total count counts mHistExemplarMap <- STM.readTVar bucketCounts + let sumSample = Sample (name <> "_sum") [] (bsShow total) Nothing + let countSample = Sample (name <> "_count") [] (bsShow count) Nothing + let infSample = Sample (name <> "_bucket") [(bucketLabel, "+Inf")] (bsShow count) Nothing let upperBoundAndCount = cumulativeSum (Map.toAscList counts) - exemplarLabelPairs = map snd (Map.toAscList labels) - samples = map toSample (zip upperBoundAndCount exemplarLabelPairs) + mHistExemplars = map snd (Map.toAscList mHistExemplarMap) + samples = map toSample (zip upperBoundAndCount mHistExemplars) return [SampleGroup info HistogramType $ samples ++ [infSample, sumSample, countSample]] where - toSample ((upperBound, count'), exemplarLabelPairs) = - Sample (name <> "_bucket") [(bucketLabel, formatFloat upperBound)] (bsShow count') exemplarLabelPairs + toSample ((upperBound, count'), mHistExemplar) = + Sample (name <> "_bucket") [(bucketLabel, formatFloat upperBound)] (bsShow count') (histExemlarToSampleExemplar <$> mHistExemplar) name = metricName info -- We don't particularly want scientific notation, so force regular @@ -148,6 +156,10 @@ collectHistogram info bucketCounts = STM.atomically $ do bsShow :: Show s => s -> BS.ByteString bsShow = BS.fromString . show + histExemlarToSampleExemplar :: HistogramExemplar -> SampleExemplar + histExemlarToSampleExemplar HistogramExemplar{..} = + SampleExemplar histExemplarLabelPairs (bsShow histExemplarValue) histExemplarTimestamp + -- | The label that defines the upper bound of a bucket of a histogram. @"le"@ -- is short for "less than or equal to". bucketLabel :: Text diff --git a/prometheus-client/src/Prometheus/Metric/Summary.hs b/prometheus-client/src/Prometheus/Metric/Summary.hs index 320d3f0..349a1d4 100644 --- a/prometheus-client/src/Prometheus/Metric/Summary.hs +++ b/prometheus-client/src/Prometheus/Metric/Summary.hs @@ -93,8 +93,8 @@ collectSummary info (MkSummary sketchVar quantiles_) = withMVar sketchVar $ \ske count_ <- ReqSketch.count sketch estimatedQuantileValues <- forM quantiles_ $ \qv -> (,) <$> pure (fst qv) <*> ReqSketch.quantile sketch (toDouble $ fst qv) - let sumSample = Sample (metricName info <> "_sum") [] (bsShow itemSum) [] - let countSample = Sample (metricName info <> "_count") [] (bsShow count_) [] + let sumSample = Sample (metricName info <> "_sum") [] (bsShow itemSum) Nothing + let countSample = Sample (metricName info <> "_count") [] (bsShow count_) Nothing return [SampleGroup info SummaryType $ map toSample estimatedQuantileValues ++ [sumSample, countSample]] where bsShow :: Show s => s -> BS.ByteString @@ -103,7 +103,7 @@ collectSummary info (MkSummary sketchVar quantiles_) = withMVar sketchVar $ \ske toSample :: (Rational, Double) -> Sample toSample (q, estimatedValue) = Sample (metricName info) [("quantile", T.pack . show $ toDouble q)] - (bsShow estimatedValue) [] + (bsShow estimatedValue) Nothing toDouble :: Rational -> Double toDouble = fromRational diff --git a/prometheus-metrics-ghc/src/Prometheus/Metric/GHC.hs b/prometheus-metrics-ghc/src/Prometheus/Metric/GHC.hs index e6c34d0..f33457d 100644 --- a/prometheus-metrics-ghc/src/Prometheus/Metric/GHC.hs +++ b/prometheus-metrics-ghc/src/Prometheus/Metric/GHC.hs @@ -350,4 +350,4 @@ showCollector :: Show a => Text -> Text -> SampleType -> a -> LabelPairs -> IO [ showCollector name help sampleType value labels = do let info = Info name help let valueBS = BS.fromString $ show value - return [SampleGroup info sampleType [Sample name labels valueBS []]] + return [SampleGroup info sampleType [Sample name labels valueBS Nothing]] From ddd56f4d0e357cd4841d6e2fb987efafa5cdf6d1 Mon Sep 17 00:00:00 2001 From: Maximilian Tagher Date: Sun, 18 May 2025 21:15:01 -0700 Subject: [PATCH 09/12] .. --- prometheus-client/src/Prometheus.hs | 1 + prometheus-client/src/Prometheus/Metric/Histogram.hs | 8 ++++++-- 2 files changed, 7 insertions(+), 2 deletions(-) diff --git a/prometheus-client/src/Prometheus.hs b/prometheus-client/src/Prometheus.hs index 5d011c0..329b5ff 100644 --- a/prometheus-client/src/Prometheus.hs +++ b/prometheus-client/src/Prometheus.hs @@ -125,6 +125,7 @@ module Prometheus ( , linearBuckets , getHistogram , observeWithExemplar +, ExemplarMetadata(..) -- ** Vector -- diff --git a/prometheus-client/src/Prometheus/Metric/Histogram.hs b/prometheus-client/src/Prometheus/Metric/Histogram.hs index ae170d6..8d8ee13 100644 --- a/prometheus-client/src/Prometheus/Metric/Histogram.hs +++ b/prometheus-client/src/Prometheus/Metric/Histogram.hs @@ -10,6 +10,7 @@ module Prometheus.Metric.Histogram ( , exponentialBuckets , linearBuckets , observeWithExemplar +, ExemplarMetadata(..) -- * Exported for testing , BucketCounts(..) @@ -56,6 +57,9 @@ histogram info buckets = Metric $ do -- | Upper-bound for a histogram bucket. type Bucket = Double +data ExemplarMetadata = ExemplarMetadata LabelPairs !(Maybe TimeSpec) + deriving (Show) + data HistogramExemplar = HistogramExemplar { histExemplarLabelPairs :: LabelPairs , histExemplarValue :: !Double @@ -97,8 +101,8 @@ instance Observer Histogram where -- This feature is experimental and must be [enabled on the Prometheus server](https://prometheus.io/docs/prometheus/latest/feature_flags/). -- -- > withLabel incomingHttpRequestSeconds "Signup_POST" (`observeWithExemplar` 1.23 [("trace_id", "12345"), ("span_id", "67890")]) -observeWithExemplar :: Histogram -> Double -> HistogramExemplar -> IO () -observeWithExemplar h v exemplar = withHistogram h (insertWithExemplar v (Just exemplar)) +observeWithExemplar :: Histogram -> Double -> ExemplarMetadata -> IO () +observeWithExemplar h v (ExemplarMetadata labelPairs mTimestamp) = withHistogram h (insertWithExemplar v (Just (HistogramExemplar labelPairs v mTimestamp))) -- | Transform the contents of a histogram. withHistogram :: MonadMonitor m From f359e4f0c25b2846e23f985d90ec25c792867cc8 Mon Sep 17 00:00:00 2001 From: Maximilian Tagher Date: Sun, 18 May 2025 21:28:05 -0700 Subject: [PATCH 10/12] fix test --- prometheus-client/src/Prometheus.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/prometheus-client/src/Prometheus.hs b/prometheus-client/src/Prometheus.hs index 329b5ff..e75489b 100644 --- a/prometheus-client/src/Prometheus.hs +++ b/prometheus-client/src/Prometheus.hs @@ -203,7 +203,7 @@ module Prometheus ( -- >>> newtype CPUTime = MkCPUTime () -- >>> let info = Info "cpu_time" "The current CPU time" -- >>> let toValue = Data.ByteString.UTF8.fromString . show --- >>> let toSample x = Sample "cpu_time" [] (toValue x) [] +-- >>> let toSample x = Sample "cpu_time" [] (toValue x) Nothing -- >>> let toSampleGroup = (:[]) . SampleGroup info GaugeType . (:[]) . toSample -- >>> let collectCPUTime = fmap toSampleGroup getCPUTime -- >>> let cpuTimeMetric = Metric (return (MkCPUTime (), collectCPUTime)) From c248953e6737684b887fe1a07e828d86e67e9c22 Mon Sep 17 00:00:00 2001 From: Maximilian Tagher Date: Sun, 18 May 2025 21:37:48 -0700 Subject: [PATCH 11/12] .. --- prometheus-client/tests/Prometheus/Export/TextSpec.hs | 9 +++++---- prometheus-proc/src/Prometheus/Metric/Proc.hs | 2 +- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/prometheus-client/tests/Prometheus/Export/TextSpec.hs b/prometheus-client/tests/Prometheus/Export/TextSpec.hs index 60eed2c..20cfc96 100644 --- a/prometheus-client/tests/Prometheus/Export/TextSpec.hs +++ b/prometheus-client/tests/Prometheus/Export/TextSpec.hs @@ -72,10 +72,10 @@ spec = before_ unregisterAll $ after_ unregisterAll $ ]) it "renders histograms with exemplars" $ do m <- register $ histogram (Info "metric" "help") defaultBuckets - observeWithExemplar m 1.0 [("trace_id", "1")] - observeWithExemplar m 1.0 [("trace_id", "2")] + observeWithExemplar m 1.0 (ExemplarMetadata [("trace_id", "1")] Nothing) + observeWithExemplar m 1.0 (ExemplarMetadata [("trace_id", "2")] Nothing) observe m 1.0 - result <- exportMetricsAsText + result <- exportMetricsAsOpenMetrics1 result `shouldBe` LT.encodeUtf8 (LT.pack $ unlines [ "# HELP metric help" , "# TYPE metric histogram" @@ -86,13 +86,14 @@ spec = before_ unregisterAll $ after_ unregisterAll $ , "metric_bucket{le=\"0.1\"} 0" , "metric_bucket{le=\"0.25\"} 0" , "metric_bucket{le=\"0.5\"} 0" - , "metric_bucket{le=\"1.0\"} 3 # {trace_id=\"2\"}" + , "metric_bucket{le=\"1.0\"} 3 # {trace_id=\"2\"} 1.0" , "metric_bucket{le=\"2.5\"} 3" , "metric_bucket{le=\"5.0\"} 3" , "metric_bucket{le=\"10.0\"} 3" , "metric_bucket{le=\"+Inf\"} 3" , "metric_sum 3.0" , "metric_count 3" + , "# EOF" ]) it "renders vectors" $ do m <- register $ vector ("handler", "method") diff --git a/prometheus-proc/src/Prometheus/Metric/Proc.hs b/prometheus-proc/src/Prometheus/Metric/Proc.hs index fc37e65..ea5b7d8 100644 --- a/prometheus-proc/src/Prometheus/Metric/Proc.hs +++ b/prometheus-proc/src/Prometheus/Metric/Proc.hs @@ -172,7 +172,7 @@ metric metricName metricHelp metricType value = metricName [] ( fromString ( show value ) ) - [] + Nothing ] From f153de62a4e7688a41286ba7faf1ad7bbf8b9f61 Mon Sep 17 00:00:00 2001 From: Maximilian Tagher Date: Mon, 19 May 2025 10:52:30 -0700 Subject: [PATCH 12/12] cleanup --- prometheus-client/src/Prometheus/Metric/Histogram.hs | 9 +++++++-- prometheus-client/src/Prometheus/Metric/Vector.hs | 4 ++-- 2 files changed, 9 insertions(+), 4 deletions(-) diff --git a/prometheus-client/src/Prometheus/Metric/Histogram.hs b/prometheus-client/src/Prometheus/Metric/Histogram.hs index 8d8ee13..5188fe6 100644 --- a/prometheus-client/src/Prometheus/Metric/Histogram.hs +++ b/prometheus-client/src/Prometheus/Metric/Histogram.hs @@ -57,6 +57,11 @@ histogram info buckets = Metric $ do -- | Upper-bound for a histogram bucket. type Bucket = Double +-- | A set of key-value pairs that correlates time series data +-- to a specific trace. +-- +-- The additional timestamp parameter is optional, but it's recommended +-- to more accurately show on a graph when the exemplar occurred. data ExemplarMetadata = ExemplarMetadata LabelPairs !(Maybe TimeSpec) deriving (Show) @@ -100,7 +105,7 @@ instance Observer Histogram where -- -- This feature is experimental and must be [enabled on the Prometheus server](https://prometheus.io/docs/prometheus/latest/feature_flags/). -- --- > withLabel incomingHttpRequestSeconds "Signup_POST" (`observeWithExemplar` 1.23 [("trace_id", "12345"), ("span_id", "67890")]) +-- > withLabel incomingHttpRequestSeconds "Signup_POST" (\hist -> observeWithExemplar hist 1.23 (P.ExemplarMetadata [("trace_id", "12345"), ("span_id", "67890")] Nothing)) observeWithExemplar :: Histogram -> Double -> ExemplarMetadata -> IO () observeWithExemplar h v (ExemplarMetadata labelPairs mTimestamp) = withHistogram h (insertWithExemplar v (Just (HistogramExemplar labelPairs v mTimestamp))) @@ -121,7 +126,7 @@ getHistogram (MkHistogram bucketsTVar) = insert :: Double -> BucketCounts -> BucketCounts insert value bucketCounts = insertWithExemplar value Nothing bucketCounts -insertWithExemplar :: Double -> (Maybe HistogramExemplar) -> BucketCounts -> BucketCounts +insertWithExemplar :: Double -> Maybe HistogramExemplar -> BucketCounts -> BucketCounts insertWithExemplar value mHistogramExemplar BucketCounts { histTotal = total, histCount = count, histCountsPerBucket = counts, histBucketExemplars = existingExemplarMap } = let updatedValues = case Map.lookupGE value counts of Nothing -> counts diff --git a/prometheus-client/src/Prometheus/Metric/Vector.hs b/prometheus-client/src/Prometheus/Metric/Vector.hs index 2e21059..b1944f1 100644 --- a/prometheus-client/src/Prometheus/Metric/Vector.hs +++ b/prometheus-client/src/Prometheus/Metric/Vector.hs @@ -67,8 +67,8 @@ collectVector keys ioref = do adjustSamples labels (SampleGroup info ty samples) = SampleGroup info ty (map (prependLabels labels) samples) - prependLabels l (Sample name labels value exemplarLabelPairs) = - Sample name (labelPairs keys l ++ labels) value exemplarLabelPairs + prependLabels l (Sample name labels value exemplar) = + Sample name (labelPairs keys l ++ labels) value exemplar joinSamples [] = [] joinSamples s@(SampleGroup i t _:_) = [SampleGroup i t (extract s)]