Add exemplars

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

prometheus-client/src/Prometheus.hs

@@ -14,6 +14,7 @@ module Prometheus (
 -- * Exporting
 
 ,   exportMetricsAsText
+,   exportMetricsAsOpenMetrics1
 
 -- * Metrics
 --
@@ -123,6 +124,8 @@ module Prometheus (
 ,   exponentialBuckets
 ,   linearBuckets
 ,   getHistogram
+,   observeWithExemplar
+,   ExemplarMetadata(..)
 
 -- ** Vector
 --
@@ -200,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 = Sample "cpu_time" [] . toValue
+-- >>> 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))

prometheus-client/src/Prometheus/Export/Text.hs

@@ -2,6 +2,7 @@
 
 module Prometheus.Export.Text (
     exportMetricsAsText
+,   exportMetricsAsOpenMetrics1
 ) where
 
 import Prometheus.Info
@@ -16,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
@@ -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
+
+-- | Export all registered metrics in the OpenMetrics 1.0.0 format.
+--
+-- For the full specification of the format, see the official Prometheus
+-- <https://prometheus.io/docs/specs/om/open_metrics_spec/ documentation>.
+--
+-- 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 :: SampleGroup -> Build.Builder
-exportSampleGroup (SampleGroup info ty samples) =
+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]
 
@@ -63,17 +85,39 @@ exportSamples samples =
   mconcat [ exportSample s <> Build.charUtf8 '\n' | s <- samples ]
 
 exportSample :: Sample -> Build.Builder
-exportSample (Sample name labels value) =
+exportSample (Sample name labels value mExemplar) =
   Build.byteString (T.encodeUtf8 name)
-    <> (case labels of
+    <> buildLabelPairs labels
+    <> Build.charUtf8 ' '
+    <> Build.byteString value
+    <> 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)
+
+        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
+             <> Build.charUtf8 '}'
 
 exportLabel :: (Text, Text) -> Build.Builder
 exportLabel (key, value) =

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, 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 (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

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.

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]]

prometheus-client/src/Prometheus/Metric/Histogram.hs

@@ -1,5 +1,6 @@
 {-# language BangPatterns #-}
 {-# language OverloadedStrings #-}
+{-# language RecordWildCards #-}
 
 module Prometheus.Metric.Histogram (
     Histogram
@@ -8,15 +9,19 @@ module Prometheus.Metric.Histogram (
 ,   defaultBuckets
 ,   exponentialBuckets
 ,   linearBuckets
+,   observeWithExemplar
+,   ExemplarMetadata(..)
 
 -- * 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
@@ -31,6 +36,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.
@@ -51,6 +57,20 @@ 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)
+
+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.
@@ -61,11 +81,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)
+,   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))
+    | 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))
@@ -74,6 +95,20 @@ 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/).
+--
+-- > 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)))
+
 -- | Transform the contents of a histogram.
 withHistogram :: MonadMonitor m
               => Histogram -> (BucketCounts -> BucketCounts) -> m ()
@@ -89,26 +124,36 @@ getHistogram (MkHistogram 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 Nothing 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
                 Just (upperBound, _) -> Map.adjust (+1) upperBound counts
 
+        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 <- 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 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)
+        mHistExemplars = map snd (Map.toAscList mHistExemplarMap)
+        samples = map toSample (zip upperBoundAndCount mHistExemplars)
     return [SampleGroup info HistogramType $ samples ++ [infSample, sumSample, countSample]]
     where
-        toSample (upperBound, count') =
-            Sample (name <> "_bucket") [(bucketLabel, formatFloat upperBound)] $ bsShow count'
+        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
@@ -120,6 +165,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

prometheus-client/src/Prometheus/Metric/Summary.hs

@@ -93,17 +93,17 @@ 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
         bsShow = BS.fromString . show
 
         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) Nothing
 
         toDouble :: Rational -> Double
         toDouble = fromRational

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 exemplar) =
+            Sample name (labelPairs keys l ++ labels) value exemplar
 
         joinSamples []                      = []
         joinSamples s@(SampleGroup i t _:_) = [SampleGroup i t (extract s)]