packages feed

hs-opentelemetry-exporter-prometheus (empty) → 1.0.0.0

raw patch · 9 files changed

+970/−0 lines, 9 filesdep +asyncdep +basedep +bytestringsetup-changed

Dependencies added: async, base, bytestring, containers, hs-opentelemetry-api, hs-opentelemetry-exporter-prometheus, hs-opentelemetry-semantic-conventions, hspec, http-client, http-types, text, unordered-containers, vector, wai, wai-extra, warp

Files

+ ChangeLog.md view
@@ -0,0 +1,13 @@+# Changelog++## Unreleased++## 1.0.0.0 - 2026-05-29++- Support `startTimeUnixNano` on all data point types+- Comprehensive Prometheus text rendering tests+- Exponential histogram rendering (approximate `le` labels), exemplar comments on samples.++## 0.1.0.0++- Initial release: Prometheus text rendering for `ResourceMetricsExport`.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Ian Duncan (c) 2021-2026++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Ian Duncan nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,5 @@+# hs-opentelemetry-exporter-prometheus++[![hs-opentelemetry-exporter-prometheus](https://img.shields.io/hackage/v/hs-opentelemetry-exporter-prometheus?style=flat-square&logo=haskell&label=hs-opentelemetry-exporter-prometheus&labelColor=5D4F85)](https://hackage.haskell.org/package/hs-opentelemetry-exporter-prometheus)++Renders `ResourceMetricsExport` batches as Prometheus text exposition.
+ Setup.hs view
@@ -0,0 +1,5 @@+import Distribution.Simple+++main :: IO ()+main = defaultMain
+ hs-opentelemetry-exporter-prometheus.cabal view
@@ -0,0 +1,73 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.38.3.+--+-- see: https://github.com/sol/hpack++name:           hs-opentelemetry-exporter-prometheus+version:        1.0.0.0+synopsis:       Prometheus text exposition for OpenTelemetry metrics export batches+description:    Please see the README on GitHub at <https://github.com/iand675/hs-opentelemetry/tree/main/exporters/prometheus#readme>+category:       OpenTelemetry, Telemetry, Monitoring, Observability, Metrics+homepage:       https://github.com/iand675/hs-opentelemetry#readme+bug-reports:    https://github.com/iand675/hs-opentelemetry/issues+author:         Ian Duncan+maintainer:     ian@iankduncan.com+copyright:      2021 Ian Duncan+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://github.com/iand675/hs-opentelemetry++library+  exposed-modules:+      OpenTelemetry.Exporter.Prometheus+      OpenTelemetry.Exporter.Prometheus.PushGateway+      OpenTelemetry.Exporter.Prometheus.WAI+  other-modules:+      Paths_hs_opentelemetry_exporter_prometheus+  hs-source-dirs:+      src+  ghc-options: -Wall+  build-depends:+      async+    , base >=4.7 && <5+    , bytestring+    , containers+    , hs-opentelemetry-api ==1.0.*+    , http-client+    , http-types+    , text+    , unordered-containers+    , vector+    , wai+    , warp+  default-language: Haskell2010++test-suite hs-opentelemetry-exporter-prometheus-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_hs_opentelemetry_exporter_prometheus+  hs-source-dirs:+      test+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.7 && <5+    , bytestring+    , hs-opentelemetry-api ==1.0.*+    , hs-opentelemetry-exporter-prometheus ==1.0.*+    , hs-opentelemetry-semantic-conventions >=1.40 && <2+    , hspec+    , http-types+    , text+    , vector+    , wai+    , wai-extra+  default-language: Haskell2010
+ src/OpenTelemetry/Exporter/Prometheus.hs view
@@ -0,0 +1,402 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++{- | Prometheus text exposition format (0.0.4) for 'ResourceMetricsExport' batches.++Labels combine resource attributes with point attributes (point wins on key clash).+Instrumentation scope name is exposed as @job@ when non-empty.++Exponential histograms are mapped to classic @histogram@ buckets using OTel-style+@le@ upper bounds derived from scale and bucket index (@2^((i+1)/2^scale)@ for positive indices).++This is intended for scraping or debugging; for production, prefer OTLP metrics.+-}+module OpenTelemetry.Exporter.Prometheus (+  renderPrometheusText,+) where++import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import Data.Char (isAsciiLower, isAsciiUpper, isDigit)+import qualified Data.HashMap.Strict as H+import Data.Int (Int32, Int64)+import Data.List (sort)+import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe, mapMaybe)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import Data.Text.Lazy.Builder (Builder, fromText, singleton, toLazyText)+import Data.Text.Lazy.Builder.Int (decimal)+import Data.Text.Lazy.Builder.RealFloat (realFloat)+import Data.Vector (Vector)+import qualified Data.Vector as V+import Data.Word (Word64)+import OpenTelemetry.Attributes+import OpenTelemetry.Exporter.Metric (+  ExponentialHistogramDataPoint (..),+  GaugeDataPoint (..),+  HistogramDataPoint (..),+  MetricExemplar (..),+  MetricExport (..),+  NumberValue (..),+  ResourceMetricsExport (..),+  ScopeMetricsExport (..),+  SumDataPoint (..),+ )+import OpenTelemetry.Internal.Common.Types (InstrumentationLibrary (..))+import OpenTelemetry.Resource (getMaterializedResourcesAttributes)+++-- | Render Prometheus text (lines separated by @\\n@, trailing newline).+renderPrometheusText :: Vector ResourceMetricsExport -> Text+renderPrometheusText batches+  | V.null batches = ""+  | otherwise =+      TL.toStrict $+        toLazyText $+          V.ifoldl'+            ( \acc i r ->+                acc <> (if i == 0 then mempty else nl) <> renderResource r+            )+            mempty+            batches+++renderResource :: ResourceMetricsExport -> Builder+renderResource ResourceMetricsExport {..} =+  let resMap = attributesToLabelMap (getMaterializedResourcesAttributes resourceMetricsResource)+  in V.ifoldl'+       ( \acc i s ->+           acc <> (if i == 0 then mempty else nl) <> renderScope resMap s+       )+       mempty+       resourceMetricsScopes+++renderScope :: Map.Map Text Text -> ScopeMetricsExport -> Builder+renderScope resMap ScopeMetricsExport {..} =+  let jobMap =+        if T.null (libraryName scopeMetricsScope)+          then resMap+          else Map.insert "job" (libraryName scopeMetricsScope) resMap+  in V.ifoldl'+       ( \acc i m ->+           acc <> (if i == 0 then mempty else nl) <> renderMetric jobMap m+       )+       mempty+       scopeMetricsExports+++intersperse :: a -> [a] -> [a]+intersperse _ [] = []+intersperse _ [x] = [x]+intersperse sep (x : xs) = x : sep : intersperse sep xs+++renderMetric :: Map.Map Text Text -> MetricExport -> Builder+renderMetric baseLabels = \case+  MetricExportSum name desc _unit _lib monotonic _isInt _temp pts ->+    let typ = if monotonic then "counter" else "gauge"+        nm = sanitizeName name+    in helpLine nm desc+         <> typeLine nm typ+         <> V.foldl'+           ( \acc p ->+               acc+                 <> fromText nm+                 <> formatLabels (mergeLabels baseLabels (attributesToLabelMap (sumDataPointAttributes p)))+                 <> sp+                 <> numberValue (sumDataPointValue p)+                 <> exemplarSuffix (sumDataPointExemplars p)+                 <> nl+           )+           mempty+           pts+  MetricExportGauge name desc _unit _lib _isInt pts ->+    let nm = sanitizeName name+    in helpLine nm desc+         <> typeLine nm "gauge"+         <> V.foldl'+           ( \acc p ->+               acc+                 <> fromText nm+                 <> formatLabels (mergeLabels baseLabels (attributesToLabelMap (gaugeDataPointAttributes p)))+                 <> sp+                 <> numberValue (gaugeDataPointValue p)+                 <> exemplarSuffix (gaugeDataPointExemplars p)+                 <> nl+           )+           mempty+           pts+  MetricExportHistogram name desc _unit _lib _temp pts ->+    let nm = sanitizeName name+    in helpLine nm desc+         <> typeLine nm "histogram"+         <> V.foldl' (\acc p -> acc <> renderHistogramPoint baseLabels nm p) mempty pts+  MetricExportExponentialHistogram name desc _unit _lib _temp pts ->+    let nm = sanitizeName name+    in helpLine nm desc+         <> typeLine nm "histogram"+         <> V.foldl' (\acc p -> acc <> renderExponentialHistogramPoint baseLabels nm p) mempty pts+++helpLine :: Text -> Text -> Builder+helpLine nm desc =+  "# HELP " <> fromText nm <> sp <> fromText (escapeHelp desc) <> nl+++typeLine :: Text -> Builder -> Builder+typeLine nm typ =+  "# TYPE " <> fromText nm <> sp <> typ <> nl+++nl :: Builder+nl = singleton '\n'+++sp :: Builder+sp = singleton ' '+++numberValue :: NumberValue -> Builder+numberValue (IntNumber i) = decimal i+numberValue (DoubleNumber d) = buildDouble d+++buildDouble :: Double -> Builder+buildDouble d+  | isNaN d = "NaN"+  | isInfinite d = if d > 0 then "+Inf" else "-Inf"+  | otherwise = realFloat d+++doubleToText :: Double -> Text+doubleToText = TL.toStrict . toLazyText . buildDouble+++buildWord64 :: Word64 -> Builder+buildWord64 = decimal+++byteStringHex :: ByteString -> Builder+byteStringHex = BS.foldl' (\acc w -> acc <> word8Hex w) mempty+  where+    word8Hex w =+      let (hi, lo) = w `divMod` 16+      in singleton (hexDigit hi) <> singleton (hexDigit lo)+    hexDigit n+      | n < 10 = toEnum (fromEnum '0' + fromIntegral n)+      | otherwise = toEnum (fromEnum 'a' + fromIntegral n - 10)+++exemplarSuffix :: V.Vector MetricExemplar -> Builder+exemplarSuffix exs+  | V.null exs = mempty+  | otherwise =+      let e = V.head exs+      in " # {trace_id=\""+           <> byteStringHex (metricExemplarTraceId e)+           <> "\",span_id=\""+           <> byteStringHex (metricExemplarSpanId e)+           <> "\"} "+           <> exemplarValue e+++exemplarValue :: MetricExemplar -> Builder+exemplarValue e = case metricExemplarValue e of+  Nothing -> "0"+  Just (IntNumber i) -> decimal i+  Just (DoubleNumber d) -> buildDouble d+++renderHistogramPoint :: Map.Map Text Text -> Text -> HistogramDataPoint -> Builder+renderHistogramPoint baseLabels hname p =+  let lbls = mergeLabels baseLabels (attributesToLabelMap (histogramDataPointAttributes p))+      bounds = histogramDataPointExplicitBounds p+      counts = histogramDataPointBucketCounts p+      cum = V.scanl1' (+) counts+      bucketName = fromText hname <> "_bucket"+      finiteB =+        V.ifoldl'+          ( \acc i b ->+              let c = cum V.! i+              in acc+                   <> bucketName+                   <> formatLabels (Map.insert "le" (doubleToText b) lbls)+                   <> sp+                   <> buildWord64 c+                   <> nl+          )+          mempty+          bounds+  in finiteB+       <> bucketName+       <> formatLabels (Map.insert "le" "+Inf" lbls)+       <> sp+       <> buildWord64 (histogramDataPointCount p)+       <> exemplarSuffix (histogramDataPointExemplars p)+       <> nl+       <> fromText hname+       <> "_sum"+       <> formatLabels lbls+       <> sp+       <> buildDouble (histogramDataPointSum p)+       <> nl+       <> fromText hname+       <> "_count"+       <> formatLabels lbls+       <> sp+       <> buildWord64 (histogramDataPointCount p)+       <> nl+++-- | Approximate @le@ upper bound for exponential bucket index (positive side).+leUpperBoundExp :: Int32 -> Int32 -> Double+leUpperBoundExp scale idx =+  2 ** ((fromIntegral idx + 1) / 2 ** fromIntegral scale)+++renderExponentialHistogramPoint :: Map.Map Text Text -> Text -> ExponentialHistogramDataPoint -> Builder+renderExponentialHistogramPoint baseLabels hname p =+  let lbls = mergeLabels baseLabels (attributesToLabelMap (exponentialHistogramDataPointAttributes p))+      sc = exponentialHistogramDataPointScale p+      posOff = exponentialHistogramDataPointPositiveOffset p+      posCnt = exponentialHistogramDataPointPositiveBucketCounts p+      negOff = exponentialHistogramDataPointNegativeOffset p+      negCnt = exponentialHistogramDataPointNegativeBucketCounts p+      posCum = if V.null posCnt then V.empty else V.scanl1' (+) posCnt+      negCum = if V.null negCnt then V.empty else V.scanl1' (+) negCnt+      bucketName = fromText hname <> "_bucket"+      buildBuckets off buckets negateLe =+        V.ifoldl'+          ( \acc i c ->+              let idx = off + fromIntegral i+                  le = (if negateLe then negate else id) (leUpperBoundExp sc idx)+              in acc+                   <> bucketName+                   <> formatLabels (Map.insert "le" (doubleToText le) lbls)+                   <> sp+                   <> buildWord64 c+                   <> nl+          )+          mempty+          buckets+      zeroB =+        if exponentialHistogramDataPointZeroCount p == 0+          then mempty+          else+            bucketName+              <> formatLabels (Map.insert "le" "0" lbls)+              <> sp+              <> buildWord64 (exponentialHistogramDataPointZeroCount p)+              <> nl+  in zeroB+       <> buildBuckets negOff negCum True+       <> buildBuckets posOff posCum False+       <> bucketName+       <> formatLabels (Map.insert "le" "+Inf" lbls)+       <> sp+       <> buildWord64 (exponentialHistogramDataPointCount p)+       <> exemplarSuffix (exponentialHistogramDataPointExemplars p)+       <> nl+       <> fromText hname+       <> "_sum"+       <> formatLabels lbls+       <> sp+       <> buildDouble (fromMaybe 0 (exponentialHistogramDataPointSum p))+       <> nl+       <> fromText hname+       <> "_count"+       <> formatLabels lbls+       <> sp+       <> buildWord64 (exponentialHistogramDataPointCount p)+       <> nl+++mergeLabels :: Map.Map Text Text -> Map.Map Text Text -> Map.Map Text Text+mergeLabels resource point = Map.union point resource+++attributesToLabelMap :: Attributes -> Map.Map Text Text+attributesToLabelMap attrs =+  Map.fromList $ mapMaybe pair $ H.toList $ getAttributeMap attrs+  where+    pair (k, v) = case attributeToLabelText v of+      Nothing -> Nothing+      Just t -> Just (k, t)+++attributeToLabelText :: Attribute -> Maybe Text+attributeToLabelText = \case+  AttributeValue p -> Just (primitiveToText p)+  AttributeArray _ -> Nothing+++primitiveToText :: PrimitiveAttribute -> Text+primitiveToText = \case+  TextAttribute t -> t+  BoolAttribute b -> if b then "true" else "false"+  DoubleAttribute d -> TL.toStrict $ toLazyText $ buildDouble d+  IntAttribute i -> TL.toStrict $ toLazyText $ decimal i+++escapeLabelValue :: Text -> Text+escapeLabelValue t =+  T.concatMap+    ( \c -> case c of+        '\\' -> "\\\\"+        '"' -> "\\\""+        '\n' -> "\\n"+        _ -> T.singleton c+    )+    t+++escapeHelp :: Text -> Text+escapeHelp = T.replace "\n" "\\n" . T.replace "\\" "\\\\"+++sanitizeName :: Text -> Text+sanitizeName =+  T.map $ \c ->+    if (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') || (c >= '0' && c <= '9') || c == '_' || c == ':'+      then c+      else '_'+++isAsciiLetter :: Char -> Bool+isAsciiLetter c = isAsciiLower c || isAsciiUpper c+++isAsciiAlphaNum :: Char -> Bool+isAsciiAlphaNum c = isAsciiLetter c || isDigit c+++formatLabels :: Map.Map Text Text -> Builder+formatLabels m+  | Map.null m = mempty+  | otherwise =+      let pairs =+            sort $+              fmap+                (\(k, v) -> (sanitizeLabelName k, escapeLabelValue v))+                (Map.toList m)+      in singleton '{'+           <> mconcat (intersperse (singleton ',') (fmap (\(k, v) -> fromText k <> "=\"" <> fromText v <> singleton '"') pairs))+           <> singleton '}'+++sanitizeLabelName :: Text -> Text+sanitizeLabelName t =+  if T.null t+    then "label"+    else+      let c0 = T.head t+          rest = T.tail t+          fixFirst =+            if isAsciiLetter c0 || c0 == '_'+              then T.singleton c0+              else "_"+      in fixFirst <> T.map (\c -> if isAsciiAlphaNum c || c == '_' then c else '_') rest
+ src/OpenTelemetry/Exporter/Prometheus/PushGateway.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++{- | Prometheus PushGateway support.++Periodically pushes metrics to a+<https://github.com/prometheus/pushgateway Prometheus PushGateway>+in text exposition format.++@+mgr <- newManager defaultManagerSettings+(provider, env) <- createMeterProvider ...+handle <- startPushGateway+  PushGatewayConfig+    { pushGatewayEndpoint = "http://pushgateway:9091"+    , pushGatewayJob      = "my-service"+    , pushGatewayIntervalSeconds = 15+    }+  mgr+  (collectResourceMetrics env)+@+-}+module OpenTelemetry.Exporter.Prometheus.PushGateway (+  PushGatewayConfig (..),+  pushMetricsOnce,+  startPushGateway,+) where++import Control.Concurrent (threadDelay)+import Control.Concurrent.Async (Async, async)+import Control.Exception (SomeException, try)+import Control.Monad (forever, void)+import qualified Data.ByteString.Lazy as LBS+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Data.Vector (Vector)+import Network.HTTP.Client (+  Manager,+  Request (..),+  RequestBody (..),+  httpNoBody,+  parseRequest,+ )+import OpenTelemetry.Exporter.Metric (ResourceMetricsExport)+import OpenTelemetry.Exporter.Prometheus (renderPrometheusText)+++data PushGatewayConfig = PushGatewayConfig+  { pushGatewayEndpoint :: Text+  -- ^ Base URL of the PushGateway, e.g. @\"http:\/\/pushgateway:9091\"@+  , pushGatewayJob :: Text+  -- ^ Value for the @job@ grouping key+  , pushGatewayIntervalSeconds :: Int+  -- ^ Seconds between pushes+  }+++{- | Push the current metrics snapshot once.++Uses HTTP PUT to @\/metrics\/job\/<job>@ which replaces all metrics+for the given job.+-}+pushMetricsOnce :: PushGatewayConfig -> Manager -> IO (Vector ResourceMetricsExport) -> IO ()+pushMetricsOnce config mgr collect = do+  metrics <- collect+  let body = LBS.fromStrict (TE.encodeUtf8 (renderPrometheusText metrics))+      url =+        T.unpack (pushGatewayEndpoint config)+          <> "/metrics/job/"+          <> T.unpack (pushGatewayJob config)+  baseReq <- parseRequest url+  let req =+        baseReq+          { method = "PUT"+          , requestBody = RequestBodyLBS body+          , requestHeaders = [("Content-Type", "text/plain; version=0.0.4; charset=utf-8")]+          }+  void $ httpNoBody req mgr+++{- | Start a background thread that periodically pushes metrics.++Returns an 'Async' handle. Errors during individual pushes are silently+swallowed to avoid crashing the application; the next push will retry.+-}+startPushGateway :: PushGatewayConfig -> Manager -> IO (Vector ResourceMetricsExport) -> IO (Async ())+startPushGateway config mgr collect = async $ forever $ do+  _ <- try @SomeException $ pushMetricsOnce config mgr collect+  threadDelay (pushGatewayIntervalSeconds config * 1000000)
+ src/OpenTelemetry/Exporter/Prometheus/WAI.hs view
@@ -0,0 +1,128 @@+{-# LANGUAGE OverloadedStrings #-}++{- | Prometheus metrics serving via WAI.++Provides a WAI 'Middleware' and standalone 'Application' for serving+OpenTelemetry metrics in Prometheus text exposition format.++== Avoiding trace noise++The 'prometheusMiddleware' short-circuits @\/metrics@ requests before they+reach any inner middleware. Compose it __outside__ the OTel WAI tracing+middleware so scrape requests never generate spans:++@+app <- prometheusMiddleware collect (otelMiddleware innerApp)+@++== Standalone server (spec-conformant)++'startPrometheusServer' reads @OTEL_EXPORTER_PROMETHEUS_HOST@ (default+@0.0.0.0@) and @OTEL_EXPORTER_PROMETHEUS_PORT@ (default @9464@) and runs+a Warp server that serves the @\/metrics@ endpoint. No OTel instrumentation+is applied to this server.+-}+module OpenTelemetry.Exporter.Prometheus.WAI (+  -- * WAI integration+  prometheusApplication,+  prometheusMiddleware,+  prometheusMiddleware',++  -- * Standalone server+  startPrometheusServer,+  startPrometheusServerAsync,++  -- * Configuration+  PrometheusExporterConfig (..),+  defaultPrometheusExporterConfig,+) where++import Control.Concurrent.Async (Async, async)+import qualified Data.ByteString.Lazy as LBS+import Data.String (fromString)+import Data.Text (Text)+import qualified Data.Text.Encoding as TE+import Data.Vector (Vector)+import Network.HTTP.Types (status200)+import Network.Wai (Application, Middleware, pathInfo, responseLBS)+import qualified Network.Wai.Handler.Warp as Warp+import OpenTelemetry.Exporter.Metric (ResourceMetricsExport)+import OpenTelemetry.Exporter.Prometheus (renderPrometheusText)+import System.Environment (lookupEnv)+import Text.Read (readMaybe)+++data PrometheusExporterConfig = PrometheusExporterConfig+  { prometheusMetricsPath :: [Text]+  -- ^ URL path segments to serve metrics at. Default: @[\"metrics\"]@+  }+++defaultPrometheusExporterConfig :: PrometheusExporterConfig+defaultPrometheusExporterConfig =+  PrometheusExporterConfig+    { prometheusMetricsPath = ["metrics"]+    }+++{- | WAI 'Application' that always responds with Prometheus metrics.++Every request path returns @200@ with the current metrics snapshot. Use+this with 'Warp.runSettings' for a dedicated metrics server, or compose+into a larger application with a router.+-}+prometheusApplication :: IO (Vector ResourceMetricsExport) -> Application+prometheusApplication collect _request respond = do+  metrics <- collect+  let body = LBS.fromStrict (TE.encodeUtf8 (renderPrometheusText metrics))+  respond $+    responseLBS+      status200+      [("Content-Type", "text/plain; version=0.0.4; charset=utf-8")]+      body+++{- | WAI 'Middleware' that intercepts @\/metrics@ and serves Prometheus text.++Requests whose 'pathInfo' matches the configured metrics path are handled+immediately; all other requests pass through to the inner application.+Place this __outside__ any OTel tracing middleware to avoid generating+spans for Prometheus scrape requests.+-}+prometheusMiddleware :: IO (Vector ResourceMetricsExport) -> Middleware+prometheusMiddleware = prometheusMiddleware' defaultPrometheusExporterConfig+++-- | Like 'prometheusMiddleware' with a custom 'PrometheusExporterConfig'.+prometheusMiddleware' :: PrometheusExporterConfig -> IO (Vector ResourceMetricsExport) -> Middleware+prometheusMiddleware' config collect inner request respond+  | pathInfo request == prometheusMetricsPath config =+      prometheusApplication collect request respond+  | otherwise =+      inner request respond+++{- | Start a standalone Prometheus HTTP server (blocking).++Reads environment variables per the OpenTelemetry specification:++* @OTEL_EXPORTER_PROMETHEUS_HOST@ — bind address (default @0.0.0.0@)+* @OTEL_EXPORTER_PROMETHEUS_PORT@ — listen port (default @9464@)++The server responds to every path with the metrics snapshot. No+OpenTelemetry instrumentation is applied to this server.+-}+startPrometheusServer :: IO (Vector ResourceMetricsExport) -> IO ()+startPrometheusServer collect = do+  host <- maybe "0.0.0.0" id <$> lookupEnv "OTEL_EXPORTER_PROMETHEUS_HOST"+  port <- maybe 9464 id . (>>= readMaybe) <$> lookupEnv "OTEL_EXPORTER_PROMETHEUS_PORT"+  let settings =+        Warp.setPort port $+          Warp.setHost (fromString host) $+            Warp.defaultSettings+  Warp.runSettings settings (prometheusApplication collect)+++-- | Like 'startPrometheusServer' but runs in a background thread.+startPrometheusServerAsync :: IO (Vector ResourceMetricsExport) -> IO (Async ())+startPrometheusServerAsync collect = async (startPrometheusServer collect)
+ test/Spec.hs view
@@ -0,0 +1,224 @@+{-# LANGUAGE OverloadedStrings #-}++import qualified Data.Text as T+import qualified Data.Vector as V+import OpenTelemetry.Attributes (addAttribute, defaultAttributeLimits, emptyAttributes)+import OpenTelemetry.Exporter.Metric (+  AggregationTemporality (..),+  GaugeDataPoint (..),+  HistogramDataPoint (..),+  MetricExport (..),+  NumberValue (..),+  ResourceMetricsExport (..),+  ScopeMetricsExport (..),+  SumDataPoint (..),+ )+import OpenTelemetry.Exporter.Prometheus (renderPrometheusText)+import OpenTelemetry.Internal.Common.Types (InstrumentationLibrary)+import OpenTelemetry.Resource (emptyMaterializedResources)+import Test.Hspec+++main :: IO ()+main = hspec $ do+  describe "OpenTelemetry.Exporter.Prometheus" $ do+    it "renders empty input as empty text" $ do+      renderPrometheusText V.empty `shouldBe` ""++    it "includes TYPE and HELP for a gauge (startTimeUnixNano on points)" $ do+      let lib = "test-lib" :: InstrumentationLibrary+          pt =+            GaugeDataPoint+              { gaugeDataPointStartTimeUnixNano = 0+              , gaugeDataPointTimeUnixNano = 1+              , gaugeDataPointValue = DoubleNumber 2.5+              , gaugeDataPointAttributes = emptyAttributes+              , gaugeDataPointExemplars = V.empty+              }+          exp =+            MetricExportGauge "my.gauge" "help text" "1" lib True $+              V.singleton pt+          rm =+            ResourceMetricsExport emptyMaterializedResources $+              V.singleton $+                ScopeMetricsExport lib (V.singleton exp)+          out = renderPrometheusText (V.singleton rm)+      T.lines out `shouldSatisfy` \ls ->+        any (T.isPrefixOf "# TYPE my_gauge gauge") ls+          && any (T.isPrefixOf "# HELP my_gauge") ls+          && any (T.isInfixOf "my_gauge") ls++    it "renders a monotonic sum as Prometheus counter type" $ do+      let lib = "test-lib" :: InstrumentationLibrary+          pt =+            SumDataPoint+              { sumDataPointStartTimeUnixNano = 0+              , sumDataPointTimeUnixNano = 10+              , sumDataPointValue = DoubleNumber 42+              , sumDataPointAttributes = emptyAttributes+              , sumDataPointExemplars = V.empty+              }+          exp =+            MetricExportSum "http.requests" "total requests" "1" lib True False AggregationCumulative $+              V.singleton pt+          rm =+            ResourceMetricsExport emptyMaterializedResources $+              V.singleton $+                ScopeMetricsExport lib (V.singleton exp)+          out = renderPrometheusText (V.singleton rm)+      out `shouldSatisfy` T.isInfixOf "# TYPE http_requests counter"+      out `shouldSatisfy` T.isInfixOf "http_requests{job=\"test-lib\"} 42.0"++    it "renders a non-monotonic sum as Prometheus gauge type" $ do+      let lib = "test-lib" :: InstrumentationLibrary+          pt =+            SumDataPoint+              { sumDataPointStartTimeUnixNano = 0+              , sumDataPointTimeUnixNano = 5+              , sumDataPointValue = IntNumber (-3)+              , sumDataPointAttributes = emptyAttributes+              , sumDataPointExemplars = V.empty+              }+          exp =+            MetricExportSum "queue.delta" "up/down" "1" lib False False AggregationDelta $+              V.singleton pt+          rm =+            ResourceMetricsExport emptyMaterializedResources $+              V.singleton $+                ScopeMetricsExport lib (V.singleton exp)+          out = renderPrometheusText (V.singleton rm)+      out `shouldSatisfy` T.isInfixOf "# TYPE queue_delta gauge"+      out `shouldSatisfy` T.isInfixOf "queue_delta{job=\"test-lib\"} -3"++    it "renders histogram buckets, _sum, _count, and +Inf" $ do+      let lib = "test-lib" :: InstrumentationLibrary+          pt =+            HistogramDataPoint+              { histogramDataPointStartTimeUnixNano = 0+              , histogramDataPointTimeUnixNano = 99+              , histogramDataPointCount = 6+              , histogramDataPointSum = 21.5+              , histogramDataPointBucketCounts = V.fromList [1, 2, 3]+              , histogramDataPointExplicitBounds = V.fromList [0.5, 1.0]+              , histogramDataPointAttributes = emptyAttributes+              , histogramDataPointMin = Nothing+              , histogramDataPointMax = Nothing+              , histogramDataPointExemplars = V.empty+              }+          exp =+            MetricExportHistogram "latency" "request latency" "ms" lib AggregationCumulative $+              V.singleton pt+          rm =+            ResourceMetricsExport emptyMaterializedResources $+              V.singleton $+                ScopeMetricsExport lib (V.singleton exp)+          out = renderPrometheusText (V.singleton rm)+      out `shouldSatisfy` T.isInfixOf "# TYPE latency histogram"+      out `shouldSatisfy` T.isInfixOf "latency_bucket{job=\"test-lib\",le=\"0.5\"} 1"+      out `shouldSatisfy` T.isInfixOf "latency_bucket{job=\"test-lib\",le=\"1.0\"} 3"+      out `shouldSatisfy` T.isInfixOf "latency_bucket{job=\"test-lib\",le=\"+Inf\"} 6"+      out `shouldSatisfy` T.isInfixOf "latency_sum{job=\"test-lib\"} 21.5"+      out `shouldSatisfy` T.isInfixOf "latency_count{job=\"test-lib\"} 6"++    it "sanitizes metric names (dots become underscores)" $ do+      let lib = "test-lib" :: InstrumentationLibrary+          pt =+            GaugeDataPoint+              { gaugeDataPointStartTimeUnixNano = 0+              , gaugeDataPointTimeUnixNano = 1+              , gaugeDataPointValue = DoubleNumber 1+              , gaugeDataPointAttributes = emptyAttributes+              , gaugeDataPointExemplars = V.empty+              }+          exp =+            MetricExportGauge "com.service.metric" "dotted name" "1" lib False $+              V.singleton pt+          rm =+            ResourceMetricsExport emptyMaterializedResources $+              V.singleton $+                ScopeMetricsExport lib (V.singleton exp)+          out = renderPrometheusText (V.singleton rm)+      out `shouldSatisfy` T.isInfixOf "# TYPE com_service_metric gauge"+      out `shouldSatisfy` T.isInfixOf "# HELP com_service_metric"+      out `shouldSatisfy` T.isInfixOf "com_service_metric{job=\"test-lib\"} 1.0"++    it "orders merged label keys lexicographically (including job)" $ do+      let lib = "test-lib" :: InstrumentationLibrary+          attrs' =+            addAttribute+              defaultAttributeLimits+              (addAttribute defaultAttributeLimits emptyAttributes "zebra" ("z" :: T.Text))+              "apple"+              ("a" :: T.Text)+          pt =+            GaugeDataPoint+              { gaugeDataPointStartTimeUnixNano = 0+              , gaugeDataPointTimeUnixNano = 1+              , gaugeDataPointValue = DoubleNumber 0+              , gaugeDataPointAttributes = attrs'+              , gaugeDataPointExemplars = V.empty+              }+          exp =+            MetricExportGauge "labels.order" "ord" "1" lib False $+              V.singleton pt+          rm =+            ResourceMetricsExport emptyMaterializedResources $+              V.singleton $+                ScopeMetricsExport lib (V.singleton exp)+          out = renderPrometheusText (V.singleton rm)+      out `shouldSatisfy` T.isInfixOf "{apple=\"a\",job=\"test-lib\",zebra=\"z\"}"++    it "escapes backslashes and double quotes in label values" $ do+      let lib = "test-lib" :: InstrumentationLibrary+          attrsEsc =+            addAttribute defaultAttributeLimits emptyAttributes "k" ("say \"hi\"\\" :: T.Text)+          ptEsc =+            GaugeDataPoint+              { gaugeDataPointStartTimeUnixNano = 0+              , gaugeDataPointTimeUnixNano = 1+              , gaugeDataPointValue = DoubleNumber 0+              , gaugeDataPointAttributes = attrsEsc+              , gaugeDataPointExemplars = V.empty+              }+          expEsc =+            MetricExportGauge "esc" "e" "1" lib False $+              V.singleton ptEsc+          rmEsc =+            ResourceMetricsExport emptyMaterializedResources $+              V.singleton $+                ScopeMetricsExport lib (V.singleton expEsc)+          outEsc = renderPrometheusText (V.singleton rmEsc)+      outEsc `shouldSatisfy` T.isInfixOf "k=\"say \\\"hi\\\"\\\\\""++    it "renders multiple gauge points with different attributes" $ do+      let lib = "test-lib" :: InstrumentationLibrary+          a1 =+            addAttribute defaultAttributeLimits emptyAttributes "route" ("/a" :: T.Text)+          a2 =+            addAttribute defaultAttributeLimits emptyAttributes "route" ("/b" :: T.Text)+          pt1 =+            GaugeDataPoint+              { gaugeDataPointStartTimeUnixNano = 0+              , gaugeDataPointTimeUnixNano = 1+              , gaugeDataPointValue = DoubleNumber 1+              , gaugeDataPointAttributes = a1+              , gaugeDataPointExemplars = V.empty+              }+          pt2 =+            GaugeDataPoint+              { gaugeDataPointStartTimeUnixNano = 0+              , gaugeDataPointTimeUnixNano = 2+              , gaugeDataPointValue = DoubleNumber 2+              , gaugeDataPointAttributes = a2+              , gaugeDataPointExemplars = V.empty+              }+          exp =+            MetricExportGauge "routes.active" "active routes" "1" lib False $+              V.fromList [pt1, pt2]+          rm =+            ResourceMetricsExport emptyMaterializedResources $+              V.singleton $+                ScopeMetricsExport lib (V.singleton exp)+          out = renderPrometheusText (V.singleton rm)+      out `shouldSatisfy` T.isInfixOf "routes_active{job=\"test-lib\",route=\"/a\"} 1.0"+      out `shouldSatisfy` T.isInfixOf "routes_active{job=\"test-lib\",route=\"/b\"} 2.0"