cardano-tracer: rework Prometheus exposition for OpenMetrics compliance

Author: mgmeier

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

@@ -75,6 +75,7 @@ main = do
         , teReforwardTraceObjects = \_-> pure ()
         , teRegistry              = handleRegistry
         , teStateDir              = Nothing
+        , teMetricsHelp           = []
         }
 
       tracerEnvRTView :: TracerEnvRTView
@@ -148,6 +149,7 @@ main = do
     , rotation       = Nothing
     , verbosity      = Nothing
     , metricsComp    = Nothing
+    , metricsHelp    = Nothing
     , hasForwarding  = Nothing
     , resourceFreq   = Nothing
     }

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

@@ -11,6 +11,7 @@ module Cardano.Tracer.Configuration
   ( Address (..)
   , Endpoint (..)
   , setEndpoint
+  , FileOrMap (..)
   , LogFormat (..)
   , LogMode (..)
   , LoggingParams (..)
@@ -24,7 +25,7 @@ module Cardano.Tracer.Configuration
 import qualified Cardano.Logging.Types as Log
 
 import           Control.Applicative ((<|>))
-import           Data.Aeson (FromJSON (..), ToJSON, withObject, (.:))
+import           Data.Aeson (FromJSON (..), ToJSON (..), withObject, (.:))
 import           Data.Fixed (Pico)
 import           Data.Function ((&))
 import           Data.Functor ((<&>))
@@ -39,10 +40,9 @@ import           Data.Text (Text)
 import           Data.Word (Word16, Word32, Word64)
 import           Data.Yaml (decodeFileEither)
 import           GHC.Generics (Generic)
+import           Network.Wai.Handler.Warp (HostPreference, Port, Settings, setHost, setPort)
 import           System.Exit (die)
 
-import Network.Wai.Handler.Warp (HostPreference, Port, Settings, setHost, setPort)
-
 -- | Only local socket is supported, to avoid unauthorized connections.
 newtype Address = LocalSocket FilePath
   deriving stock (Eq, Generic, Show)
@@ -119,6 +119,17 @@ data Verbosity
   deriving stock (Eq, Generic, Show)
   deriving anyclass (FromJSON, ToJSON)
 
+newtype FileOrMap = FOM (Either FilePath (Map Text Text))
+  deriving stock (Eq, Show)
+
+instance ToJSON FileOrMap where
+  toJSON      (FOM fom) = either toJSON toJSON fom
+  toEncoding  (FOM fom) = either toEncoding toEncoding fom
+
+instance FromJSON FileOrMap where
+  parseJSON v =
+    (FOM . Left <$> parseJSON v) <|> (FOM . Right <$> parseJSON v)
+
 -- | Tracer configuration.
 data TracerConfig = TracerConfig
   { networkMagic   :: !Word32                       -- ^ Network magic from genesis the node is launched with.
@@ -138,6 +149,7 @@ data TracerConfig = TracerConfig
   , rotation       :: !(Maybe RotationParams)       -- ^ Rotation parameters.
   , verbosity      :: !(Maybe Verbosity)            -- ^ Verbosity of the tracer itself.
   , metricsComp    :: !(Maybe (Map Text Text))      -- ^ Metrics compatibility map from metrics name to metrics name
+  , metricsHelp    :: !(Maybe FileOrMap)            -- ^ JSON file or object containing a key-value map "metric name -> help text" for Prometheus "# HELP " annotations
   , resourceFreq   :: !(Maybe Int)                  -- ^ Frequency (1/millisecond) for gathering resource data.
   }
   deriving stock (Eq, Show, Generic)

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

@@ -17,6 +17,9 @@ import           Cardano.Tracer.MetaTrace
 import           Cardano.Tracer.Types
 
 import           Control.Concurrent.Extra (Lock)
+import           Data.Text (Text)
+import           Data.Text.Lazy.Builder (Builder)
+
 
 -- | Environment for all functions.
 data TracerEnv = TracerEnv
@@ -32,6 +35,7 @@ data TracerEnv = TracerEnv
   , teReforwardTraceObjects :: !([TraceObject] -> IO ())
   , teRegistry              :: !HandleRegistry
   , teStateDir              :: !(Maybe FilePath)
+  , teMetricsHelp           :: !([(Text, Builder)])
   }
 
 #if RTVIEW

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

@@ -8,27 +8,32 @@ module Cardano.Tracer.Handlers.Metrics.Prometheus
 
 import           Cardano.Tracer.Configuration
 import           Cardano.Tracer.Environment
+import           Cardano.Tracer.Handlers.Metrics.Utils
 import           Cardano.Tracer.MetaTrace
 
 import           Prelude hiding (head)
 
+import qualified Data.ByteString as ByteString
 import           Data.ByteString.Builder (stringUtf8)
+import           Data.Char
 import           Data.Functor ((<&>))
+import qualified Data.HashMap.Strict as HM
+import           Data.List (find)
 import           Data.Map.Strict (Map)
+import qualified Data.Map.Strict as M
 import           Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.Lazy as TL
+import           Data.Text.Lazy.Builder (Builder)
+import qualified Data.Text.Lazy.Builder as TB
+import qualified Data.Text.Lazy.Builder.Int as TB
+import qualified Data.Text.Lazy.Encoding as TL
 import           Network.HTTP.Types
 import           Network.Wai hiding (responseHeaders)
-import           Network.Wai.Handler.Warp (runSettings, defaultSettings)
+import           Network.Wai.Handler.Warp (defaultSettings, runSettings)
+import qualified System.Metrics as EKG
 import           System.Metrics (Sample, Value (..), sampleAll)
 import           System.Time.Extra (sleep)
-import qualified Cardano.Tracer.Handlers.Metrics.Utils as Utils
-import qualified Data.ByteString as ByteString
-import qualified Data.HashMap.Strict as HM
-import qualified Data.Map.Strict as Map
-import qualified Data.Text as T
-import qualified Data.Text.Lazy as Lazy.Text
-import qualified Data.Text.Lazy.Encoding as Lazy.Text
-import qualified System.Metrics as EKG
 
 -- | Runs simple HTTP server that listens host and port and returns
 --   the list of currently connected nodes in such a format:
@@ -52,7 +57,7 @@ import qualified System.Metrics as EKG
 runPrometheusServer
   :: TracerEnv
   -> Endpoint
-  -> IO Utils.RouteDictionary
+  -> IO RouteDictionary
   -> IO ()
 runPrometheusServer tracerEnv endpoint computeRoutes_autoUpdate = do
   -- Pause to prevent collision between "Listening"-notifications from servers.
@@ -64,90 +69,126 @@ runPrometheusServer tracerEnv endpoint computeRoutes_autoUpdate = do
     { ttPrometheusEndpoint = endpoint
     }
   runSettings (setEndpoint endpoint defaultSettings) do
-    renderPrometheus computeRoutes_autoUpdate metricsComp where
+    renderPrometheus computeRoutes_autoUpdate metricsComp teMetricsHelp where
 
   TracerEnv
     { teTracer
     , teConfig = TracerConfig { metricsComp }
+    , teMetricsHelp
     } = tracerEnv
 
-renderPrometheus :: IO Utils.RouteDictionary -> Maybe (Map Text Text) -> Application
-renderPrometheus computeRoutes_autoUpdate metricsComp request send = do
-  routeDictionary :: Utils.RouteDictionary <-
+renderPrometheus
+  :: IO RouteDictionary
+  -> Maybe (Map Text Text)
+  -> [(Text, Builder)]
+  -> Application
+renderPrometheus computeRoutes_autoUpdate metricsComp helpTextDict request send = do
+  routeDictionary :: RouteDictionary <-
     computeRoutes_autoUpdate
 
-  let header :: RequestHeaders
-      header = requestHeaders request
-
-  let wantsJson :: Bool
-      wantsJson = all @Maybe ("application/json" `ByteString.isInfixOf`) (lookup hAccept header)
+  let acceptHeader :: Maybe ByteString.ByteString
+      acceptHeader = lookup hAccept $ requestHeaders request
 
-  let responseHeaders :: ResponseHeaders
-      responseHeaders = [(hContentType, if wantsJson then "application/json" else "text/html")]
+  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 $ responseLBS status200 responseHeaders if wantsJson
-        then Utils.renderJson routeDictionary
-        else Utils.renderListOfConnectedNodes "Prometheus metrics" (Utils.nodeNames routeDictionary)
+      send $ uncurry (responseLBS status200) $ if wantsJson
+        then (contentHdrJSON    , renderJson routeDictionary)
+        else (contentHdrUtf8Html, renderListOfConnectedNodes "Prometheus metrics" (nodeNames routeDictionary))
 
     route:_
-      | Just (store :: EKG.Store, _) <- lookup route (Utils.getRouteDictionary routeDictionary)
-     -> do metrics <- getMetricsFromNode metricsComp store
-           send $ responseLBS status200 [(hContentType, "text/plain")] (Lazy.Text.encodeUtf8 (Lazy.Text.fromStrict metrics))
+      | Just (store :: EKG.Store, _) <- lookup route (getRouteDictionary routeDictionary)
+     -> do metrics <- getMetricsFromNode metricsComp helpTextDict store
+           send $ responseBuilder status200
+            (if wantsOpenMetrics then contentHdrOpenMetrics else contentHdrUtf8Text)
+            (TL.encodeUtf8Builder metrics)
 
-      -- all endings in ekg-wai's asset/ folder
       | otherwise
-     -> send $ responseBuilder status404 [(hContentType, "text/plain")] do
+     -> send $ responseBuilder status404 contentHdrUtf8Text do
         "Not found: "
           <> stringUtf8 (show route)
 
-type MetricName  = Text
-type MetricValue = Text
-type MetricsList = [(MetricName, MetricValue)]
+type MetricName = Text
 
 getMetricsFromNode
-  :: Maybe (Map Text Text)
+  :: Maybe (Map MetricName MetricName)
+  -> [(Text, Builder)]
   -> EKG.Store
-  -> IO Text
-getMetricsFromNode metricsComp ekgStore =
-  sampleAll ekgStore <&> renderListOfMetrics . getListOfMetrics
- where
-
-  getListOfMetrics :: Sample -> MetricsList
-  getListOfMetrics =
-    metricsCompatibility
-    . filter (not . T.null . fst)
-    . map metricsWeNeed
-    . HM.toList
-
-  metricsWeNeed :: (Text, Value) -> (Text, Text)
-  metricsWeNeed (mName, mValue) =
-    case mValue of
-      Counter c -> (mName, T.pack $ show c)
-      Gauge g   -> (mName, T.pack $ show g)
-      Label l   -> (mName, l)
-      _         -> ("",    "") -- 'ekg-forward' doesn't support 'Distribution' yet.
-
-  metricsCompatibility :: MetricsList -> MetricsList
-  metricsCompatibility metricsList =
-    case metricsComp of
-      Nothing -> metricsList
-      Just mmap -> foldl (\ accu p'@(mn,mv) -> case Map.lookup mn mmap of
-                                             Nothing -> p' : accu
-                                             Just rep -> p' : (rep,mv) : accu)
-                         []
-                         metricsList
-
-  renderListOfMetrics :: MetricsList -> Text
-  renderListOfMetrics [] = "No metrics were received from this node."
-  renderListOfMetrics mList = T.intercalate "\n" $
-    map (\(mName, mValue) -> prepareName mName <> " " <> mValue) mList
-
-  prepareName :: Text -> Text
-  prepareName =
-      T.filter (`elem` (['0'..'9'] ++ ['a'..'z'] ++ ['A'..'Z'] ++ ['_']))
-    . T.replace " " "_"
-    . T.replace "-" "_"
-    . T.replace "." "_"
+  -> IO TL.Text
+getMetricsFromNode metricsComp helpTextDict ekgStore =
+  sampleAll ekgStore <&> renderExpositionFromSample metricsComp helpTextDict
+
+renderExpositionFromSample
+  :: Maybe (Map MetricName MetricName)
+  -> [(MetricName, Builder)]
+  -> Sample
+  -> TL.Text
+renderExpositionFromSample renameMap helpTextDict =
+  TB.toLazyText . (`mappend` buildEOF) . HM.foldlWithKey' buildMetric mempty
+  where
+    buildHelpText :: MetricName -> (Builder -> Builder)
+    buildHelpText name = maybe
+      (const mempty)
+      (buildHelp . snd)
+      (find ((`T.isInfixOf` name) . fst) helpTextDict)
+
+    -- implements the metricsComp config option
+    replaceName :: MetricName -> MetricName
+    replaceName =
+      case renameMap of
+        Nothing   -> Prelude.id
+        Just mmap -> \name -> M.findWithDefault name name mmap
+
+    prepareName :: MetricName -> MetricName
+    prepareName =
+        T.filter (\c -> isAsciiLower c || isAsciiUpper c || isDigit c || c == '_')
+      . T.replace " " "_"
+      . T.replace "-" "_"
+      . T.replace "." "_"
+
+    -- the help annotation line
+    buildHelp :: Builder -> Builder -> Builder
+    buildHelp h n =
+      TB.fromText "# HELP " `mappend` (n `mappend` (space `mappend` (h `mappend` newline)))
+
+    buildMetric :: TB.Builder -> MetricName -> Value -> TB.Builder
+    buildMetric acc mName mValue =
+      acc `mappend` case mValue of
+        Counter c -> annotate buildCounter `mappend` buildVal space  (TB.decimal c)
+        Gauge g   -> annotate buildGauge   `mappend` buildVal space  (TB.decimal g)
+        Label l
+          | Just ('{', _) <- T.uncons l
+                  -> annotate buildInfo    `mappend` buildVal mempty (TB.fromText l)
+          | otherwise
+                  -> helpAnnotation        `mappend` buildVal space  (TB.fromText l)
+        _         ->                                 mempty
+      where
+        helpAnnotation = buildHelpText mName buildName
+
+        -- annotates a metric in the order TYPE, UNIT, HELP
+        -- TODO: UNIT annotation
+        annotate annType =
+          buildTypeAnn annType `mappend` helpAnnotation
+
+        -- the name for exposition
+        buildName = TB.fromText $ prepareName $ replaceName mName
+
+        -- the type annotation line
+        buildTypeAnn t =
+          TB.fromText "# TYPE " `mappend` (buildName `mappend` (t `mappend` newline))
+
+        -- the actual metric line, optional spacing after name, because of labels: 'metric_name{label_value="foo"} 1'
+        buildVal spacing v =
+          buildName `mappend` (spacing `mappend` (v `mappend` newline))
+
+buildGauge, buildCounter, buildInfo, buildEOF, newline, space :: Builder
+buildGauge    = TB.fromText " gauge"
+buildCounter  = TB.fromText " counter"
+buildInfo     = TB.fromText " info"
+buildEOF      = TB.fromText "# EOF\n"
+newline       = TB.singleton '\n'
+space         = TB.singleton ' '

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

@@ -2,31 +2,30 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 module Cardano.Tracer.Handlers.Metrics.Utils
-  ( RouteDictionary(..)
-  , renderListOfConnectedNodes
-  , renderJson
-  , nodeNames
-  , computeRoutes
+  ( module Cardano.Tracer.Handlers.Metrics.Utils
   ) where
 
-import qualified Data.ByteString.Lazy as Lazy
-import           Data.Foldable (for_)
-import qualified Data.Map as Map
-import           Data.Map (Map)
-import           Data.Text (Text)
-import qualified Data.Text as T
+import           Cardano.Tracer.Environment (TracerEnv (..))
+import           Cardano.Tracer.Types (MetricsStores, NodeId, NodeName)
+
 import           Prelude hiding (head)
-import qualified Data.Bimap as Bimap
 
 import           Control.Concurrent.STM (atomically)
 import           Control.Concurrent.STM.TVar (readTVar)
 import           Data.Aeson (encode)
-import           Cardano.Tracer.Environment (TracerEnv(..))
+import qualified Data.Bimap as Bimap
+import qualified Data.ByteString.Lazy as Lazy
+import           Data.Foldable (for_)
+import           Data.Map (Map)
+import qualified Data.Map as Map
+import           Data.Text (Text)
+import qualified Data.Text as T
+import           Network.HTTP.Types (ResponseHeaders, hContentType)
 import qualified System.Metrics as EKG
-import           Cardano.Tracer.Types (NodeName, NodeId, MetricsStores)
 import           Text.Blaze.Html (Html)
 import           Text.Blaze.Html.Renderer.Utf8 (renderHtml)
-import           Text.Blaze.Html5 (Markup, a, li, ul, body, title, head, (!), textValue, html, toHtml) -- hiding (map)
+import           Text.Blaze.Html5 (Markup, a, body, head, html, li, textValue, title, toHtml, ul,
+                   (!))
 import           Text.Blaze.Html5.Attributes hiding (title)
 import           Text.Slugify (slugify)
 
@@ -82,3 +81,11 @@ computeRoutes TracerEnv{teConnectedNodesNames, teAcceptedMetrics} = atomically d
                ]
 
   pure (RouteDictionary routes)
+
+
+
+contentHdrJSON, contentHdrOpenMetrics, contentHdrUtf8Html, contentHdrUtf8Text :: 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")]