cardano-tracer: Prometheus HTTP service discovery

Author: mgmeier

cardano-tracer/bench/cardano-tracer-bench.hs

@@ -155,6 +155,7 @@ main = do
     , hasForwarding  = Nothing
     , resourceFreq   = Nothing
     , ekgRequestFull = Nothing
+    , prometheusLabels = Nothing
     }
 
   generate :: Int -> IO [TraceObject]

cardano-tracer/src/Cardano/Tracer/Configuration.hs

@@ -196,13 +196,14 @@ data TracerConfig = TracerConfig
                               , Maybe [[Text]]
                               , Log.TraceOptionForwarder
                               ))
-  , logging         :: !(NonEmpty LoggingParams)    -- ^ Logging parameters.
-  , rotation        :: !(Maybe RotationParams)      -- ^ Rotation parameters.
-  , verbosity       :: !(Maybe Verbosity)           -- ^ Verbosity of the tracer itself.
-  , metricsNoSuffix :: !(Maybe Bool)                -- ^ Prometheus ONLY: Dropping metrics name suffixes (like "_int") increases similiarity with old system names - if desired; default: False
-  , metricsHelp     :: !(Maybe FileOrMap)           -- ^ Prometheus ONLY: JSON file or object containing a key-value map "metric name -> help text" for "# HELP " annotations
-  , resourceFreq    :: !(Maybe Int)                 -- ^ Frequency (1/millisecond) for gathering resource data.
-  , ekgRequestFull  :: !(Maybe Bool)                -- ^ Request full set of metrics always, vs. deltas only (safer, but more overhead); default: False
+  , logging           :: !(NonEmpty LoggingParams)  -- ^ Logging parameters.
+  , rotation          :: !(Maybe RotationParams)    -- ^ Rotation parameters.
+  , verbosity         :: !(Maybe Verbosity)         -- ^ Verbosity of the tracer itself.
+  , metricsNoSuffix   :: !(Maybe Bool)              -- ^ Prometheus ONLY: Dropping metrics name suffixes (like "_int") increases similiarity with old system names - if desired; default: False
+  , metricsHelp       :: !(Maybe FileOrMap)         -- ^ Prometheus ONLY: JSON file or object containing a key-value map "metric name -> help text" for "# HELP " annotations
+  , resourceFreq      :: !(Maybe Int)               -- ^ Frequency (1/millisecond) for gathering resource data.
+  , ekgRequestFull    :: !(Maybe Bool)              -- ^ Request full set of metrics always, vs. deltas only (safer, but more overhead); default: False
+  , prometheusLabels  :: !(Maybe (Map Text Text))   -- ^ A common label set for all Prometheus scrape targets (only used in Prometheus HTTP service discovery)
   }
   deriving stock (Eq, Show, Generic)
   deriving anyclass (FromJSON, ToJSON)

cardano-tracer/src/Cardano/Tracer/Handlers/Metrics/Prometheus.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE ViewPatterns #-}
 
 module Cardano.Tracer.Handlers.Metrics.Prometheus
   ( runPrometheusServer
@@ -14,23 +15,27 @@ import           Cardano.Tracer.MetaTrace
 
 import           Prelude hiding (head)
 
+import           Control.Applicative ((<|>))
+import           Data.Aeson (ToJSON (..), encode, pairs, (.=))
 import qualified Data.ByteString as ByteString
-import           Data.ByteString.Builder (stringUtf8)
 import           Data.Functor ((<&>))
-import           Data.Text (Text)
+import qualified Data.Map as Map (Map, empty, fromList)
+import           Data.Maybe
+import           Data.Text as T (Text, cons)
+import qualified Data.Text.Encoding as T (decodeUtf8)
 import qualified Data.Text.Lazy as TL
 import           Data.Text.Lazy.Builder (Builder)
 import qualified Data.Text.Lazy.Encoding as TL
 import           Network.HTTP.Types
-import           Network.Wai hiding (responseHeaders)
+import           Network.Wai
 import           Network.Wai.Handler.Warp (defaultSettings, runSettings)
 import           System.Metrics as EKG (Store, sampleAll)
 import           System.Time.Extra (sleep)
 
 -- | Runs a simple HTTP server that listens on @endpoint@.
 --
 --   At the root, it lists the connected nodes, either as HTML or JSON, depending
---   on the requests 'Accept: ' header.
+--   on the request's 'Accept: ' header.
 --
 --   Routing is dynamic, depending on the connected nodes. A valid URL is derived
 --   from the nodeName configured for the connecting node. E.g. a node name
@@ -40,10 +45,6 @@ import           System.Time.Extra (sleep)
 -- # TYPE Mem_resident_int gauge
 -- # HELP Mem_resident_int Kernel-reported RSS (resident set size)
 -- Mem_resident_int 103792640
--- # TYPE rts_gc_max_bytes_used gauge
--- rts_gc_max_bytes_used 5811512
--- # TYPE rts_gc_gc_cpu_ms counter
--- rts_gc_gc_cpu_ms 50
 -- # TYPE RTS_gcMajorNum_int gauge
 -- # HELP RTS_gcMajorNum_int Major GCs
 -- RTS_gcMajorNum_int 4
@@ -56,6 +57,23 @@ import           System.Time.Extra (sleep)
 -- # TYPE nodeCannotForge_int gauge
 -- # HELP nodeCannotForge_int How many times was this node unable to forge [a block]?
 --
+--  The `/targets` path can be used for Prometheus HTTP service discovery. This lets
+--  Prometheus dynamically discover all connected nodes, and scrape their metrics.
+--  Below is a minimal example of a corresponding job definition that goes into the
+--  `prometheus.yml` configuration:
+--
+--    - job_name: "cardano-tracer"
+--
+--      http_sd_configs:
+--        - url: 'http://127.0.0.1:3200/targets'    # <-- Your cardano-tracer's real hostname:prometheus port
+--
+--  Each target will have a label "node_name" which corresponds to the TraceOptionNodeName setting in the node config.
+--
+--  In cardano-tracer's config, you can optionally provide additional labels to be attached to *all* targets
+--  (default is no additional labels):
+--    "prometheusLabels": {
+--        "<labelname>": "<labelvalue>", ...
+--      }
 runPrometheusServer
   :: TracerEnv
   -> Endpoint
@@ -71,50 +89,79 @@ runPrometheusServer tracerEnv endpoint computeRoutes_autoUpdate = do
     { ttPrometheusEndpoint = endpoint
     }
   runSettings (setEndpoint endpoint defaultSettings) do
-    renderPrometheus computeRoutes_autoUpdate noSuffix teMetricsHelp
+    renderPrometheus computeRoutes_autoUpdate noSuffix teMetricsHelp promLabels
   where
     TracerEnv
       { teTracer
-      , teConfig = TracerConfig { metricsNoSuffix }
+      , teConfig = TracerConfig { metricsNoSuffix, prometheusLabels }
       , teMetricsHelp
       } = tracerEnv
 
-    noSuffix = or @Maybe metricsNoSuffix
+    noSuffix    = or @Maybe metricsNoSuffix
+    promLabels  = fromMaybe Map.empty prometheusLabels
 
 renderPrometheus
   :: IO RouteDictionary
   -> Bool
   -> [(Text, Builder)]
+  -> Map.Map Text Text
   -> Application
-renderPrometheus computeRoutes_autoUpdate noSuffix helpTextDict request send = do
+renderPrometheus computeRoutes_autoUpdate noSuffix helpTextDict promLabels request send = do
   routeDictionary :: RouteDictionary <-
     computeRoutes_autoUpdate
 
-  let acceptHeader :: Maybe ByteString.ByteString
-      acceptHeader = lookup hAccept $ requestHeaders request
-
-  let wantsJson, wantsOpenMetrics :: Bool
-      wantsJson         = all @Maybe ("application/json"             `ByteString.isInfixOf`) acceptHeader
-      wantsOpenMetrics  = all @Maybe ("application/openmetrics-text" `ByteString.isInfixOf`) acceptHeader
-
   case pathInfo request of
 
     [] ->
       send $ uncurry (responseLBS status200) $ if wantsJson
         then (contentHdrJSON    , renderJson routeDictionary)
         else (contentHdrUtf8Html, renderListOfConnectedNodes "Prometheus metrics" routeDictionary)
 
+    ["targets"]
+      | wantsJson
+      -> serviceDiscovery routeDictionary
+
+      | otherwise
+      -> wrongMType
+
     route:_
       | Just (store :: EKG.Store, _) <- lookup route (getRouteDictionary routeDictionary)
-     -> do metrics <- getMetricsFromNode noSuffix helpTextDict store
-           send $ responseBuilder status200
-            (if wantsOpenMetrics then contentHdrOpenMetrics else contentHdrUtf8Text)
-            (TL.encodeUtf8Builder metrics)
+     -> metricsExposition store
 
       | otherwise
-     -> send $ responseBuilder status404 contentHdrUtf8Text do
-        "Not found: "
-          <> stringUtf8 (show route)
+     -> notFound route
+
+  where
+    acceptHeader :: Maybe ByteString.ByteString
+    acceptHeader = lookup hAccept $ requestHeaders request
+
+    wantsJson, wantsOpenMetrics :: Bool
+    wantsJson         = all @Maybe ("application/json"             `ByteString.isInfixOf`) acceptHeader
+    wantsOpenMetrics  = all @Maybe ("application/openmetrics-text" `ByteString.isInfixOf`) acceptHeader
+
+    -- we might support the more complex 'Forward:' header in the future
+    getHostNameRequest :: Maybe ByteString.ByteString
+    getHostNameRequest =
+          lookup "x-forwarded-host" (requestHeaders request)
+      <|> requestHeaderHost request
+
+    metricsExposition store = do
+      metrics <- getMetricsFromNode noSuffix helpTextDict store
+      send $ responseBuilder status200
+        (if wantsOpenMetrics then contentHdrOpenMetrics else contentHdrPrometheus)
+        (TL.encodeUtf8Builder metrics)
+
+    serviceDiscovery (RouteDictionary routeDict) =
+      send $ responseLBS status200 contentHdrJSON $
+        case getHostNameRequest of
+          Just (T.decodeUtf8 -> hostName) -> encode
+            [PSD (slug, nodeName, hostName, promLabels) | (slug, (_, nodeName)) <- routeDict]
+          Nothing -> "[]"
+
+    notFound t = send $ responseLBS status404 contentHdrUtf8Text $
+      "Not found: " <> (TL.encodeUtf8 . TL.fromStrict) t
+    wrongMType = send $ responseLBS status415 contentHdrUtf8Text
+      "Unsupported Media Type"
 
 getMetricsFromNode
   :: Bool
@@ -123,3 +170,21 @@ getMetricsFromNode
   -> IO TL.Text
 getMetricsFromNode noSuffix helpTextDict ekgStore =
   sampleAll ekgStore <&> renderExpositionFromSampleWith helpTextDict noSuffix
+
+
+-- This wrapper type implements the Prometheus HTTP SD format
+-- cf. https://prometheus.io/docs/prometheus/latest/http_sd
+-- It is local to this module, and never expected to provide an Aeson.Value.
+newtype PrometheusServiceDiscovery = PSD (Text, Text, Text, Map.Map Text Text)
+
+instance ToJSON PrometheusServiceDiscovery where
+  toJSON _ = error "ToJSON.toJSON(PrometheusServiceDiscovery): implementation error"
+
+  toEncoding (PSD (slug, nodeName, hostName, labelMap)) = pairs $
+       ("targets" .= [hostName])
+    <> ("labels"  .= (labels <> labelMap))
+    where
+      labels = Map.fromList
+        [ ("__metrics_path__", '/' `T.cons` slug)
+        , ("node_name"       , nodeName)
+        ]

cardano-tracer/src/Cardano/Tracer/Handlers/Metrics/Utils.hs

@@ -85,8 +85,9 @@ computeRoutes TracerEnv{teConnectedNodesNames, teAcceptedMetrics} = atomically d
 
 
 
-contentHdrJSON, contentHdrOpenMetrics, contentHdrUtf8Html, contentHdrUtf8Text :: ResponseHeaders
+contentHdrJSON, contentHdrOpenMetrics, contentHdrUtf8Html, contentHdrUtf8Text, contentHdrPrometheus :: ResponseHeaders
 contentHdrJSON        = [(hContentType, "application/json")]
-contentHdrOpenMetrics = [(hContentType, "application/openmetrics-text; version=1.0.0; charset=utf-8")]
-contentHdrUtf8Html    = [(hContentType, "text/html; charset=utf-8")]
-contentHdrUtf8Text    = [(hContentType, "text/plain; charset=utf-8")]
+contentHdrOpenMetrics = [(hContentType, "application/openmetrics-text;version=1.0.0;charset=utf-8")]
+contentHdrUtf8Html    = [(hContentType, "text/html;charset=utf-8")]
+contentHdrUtf8Text    = [(hContentType, "text/plain;charset=utf-8")]
+contentHdrPrometheus  = [(hContentType, "text/plain;version=0.0.4;charset=utf-8")]

cardano-tracer/src/Cardano/Tracer/Handlers/State/TraceObjects.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
 
 module Cardano.Tracer.Handlers.State.TraceObjects
   ( LogsLiveViewCounters

cardano-tracer/test/Cardano/Tracer/Test/Acceptor.hs

@@ -119,6 +119,7 @@ launchAcceptorsSimple mode localSock dpName = do
     , hasForwarding  = Nothing
     , resourceFreq   = Nothing
     , ekgRequestFull = Nothing
+    , prometheusLabels = Nothing
     }
 
 -- | To be able to ask any 'DataPoint' by the name without knowing the actual type,

cardano-tracer/test/Cardano/Tracer/Test/DataPoint/Tests.hs

@@ -96,4 +96,5 @@ propDataPoint ts@TestSetup{..} rootDir localSock = do
     , hasForwarding  = Nothing
     , resourceFreq   = Nothing
     , ekgRequestFull = Nothing
+    , prometheusLabels = Nothing
     }

cardano-tracer/test/Cardano/Tracer/Test/Logs/Tests.hs

@@ -82,6 +82,7 @@ propLogs ts@TestSetup{..} format logRotLimitBytes logRotMaxAgeMinutes rootDir lo
     , hasForwarding  = Nothing
     , resourceFreq   = Nothing
     , ekgRequestFull = Nothing
+    , prometheusLabels = Nothing
     }
 
 propMultiInit :: TestSetup Identity -> LogFormat -> FilePath -> HowToConnect -> HowToConnect -> IO Property
@@ -121,6 +122,7 @@ propMultiInit ts@TestSetup{..} format rootDir howToConnect1 howToConnect2 = do
     , hasForwarding  = Nothing
     , resourceFreq   = Nothing
     , ekgRequestFull = Nothing
+    , prometheusLabels = Nothing
     }
 
 -- | Tests
@@ -163,6 +165,7 @@ propMultiResp ts@TestSetup{..} format rootDir howToConnect = do
     , hasForwarding  = Nothing
     , resourceFreq   = Nothing
     , ekgRequestFull = Nothing
+    , prometheusLabels = Nothing
     }
 
 checkPropLogsResults :: FilePath -> LogFormat -> IO Property

cardano-tracer/test/Cardano/Tracer/Test/Restart/Tests.hs

@@ -102,4 +102,5 @@ mkConfig TestSetup{..} rootDir p = TracerConfig
   , hasForwarding  = Nothing
   , resourceFreq   = Nothing
   , ekgRequestFull = Nothing
+  , prometheusLabels = Nothing
   }

trace-dispatcher/src/Cardano/Logging/Prometheus/TCPServer.hs

@@ -87,16 +87,14 @@ buildResponse getCurrentExposition = \case
     | method == UNSUPPORTED -> pure $ responseError withBody errorBadMethod
     | accept == Unsupported -> pure $ responseError withBody errorBadContent
     | otherwise ->
-        let content = if accept == OpenMetrics then hdrContentTypeOpenMetrics else hdrContentTypeText
+        let content = if accept == OpenMetrics then hdrContentTypeOpenMetrics else hdrContentTypePrometheus
         in responseMessage withBody content <$> getCurrentExposition <*> epochTime
     where withBody = method == GET
 
-hdrContentType :: [ByteString] -> Builder
-hdrContentType = mconcat . ("Content-Type: " :) . intersperse (char8 ';') . map byteString
-
-hdrContentTypeText, hdrContentTypeOpenMetrics :: Builder
-hdrContentTypeText        = hdrContentType ["text/plain", "charset=utf-8"]
-hdrContentTypeOpenMetrics = hdrContentType ["application/openmetrics-text", "version=1.0.0", "charset=utf-8"]
+hdrContentTypeText, hdrContentTypePrometheus, hdrContentTypeOpenMetrics :: Builder
+hdrContentTypeText        = "Content-Type: text/plain;charset=utf-8"
+hdrContentTypePrometheus  = "Content-Type: text/plain;version=0.0.4;charset=utf-8"
+hdrContentTypeOpenMetrics = "Content-Type: application/openmetrics-text;version=1.0.0;charset=utf-8"
 
 hdrContentLength :: Int64 -> Builder
 hdrContentLength len = "Content-Length: " <> int64Dec len