try: enhance Prometheus output

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

@@ -126,6 +126,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 FilePath)             -- ^ JSON file 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

@@ -19,18 +19,24 @@ import           Control.Concurrent.STM.TVar (readTVarIO)
 import           Control.Monad (forever)
 import           Control.Monad.IO.Class (liftIO)
 import qualified Data.Bimap as BM
+import           Data.Char
 import           Data.Function ((&))
 import           Data.Functor ((<&>))
+import           Data.List (find)
 import qualified Data.HashMap.Strict as HM
 import qualified Data.Map.Strict as M
 import           Data.String (IsString (..))
 import           Data.Text (Text)
 import qualified Data.Text as T
 import           Data.Text.Encoding (decodeUtf8, encodeUtf8)
+import qualified Data.Text.Lazy as TL (Text, toStrict)
+import           Data.Text.Lazy.Builder (Builder)
+import qualified Data.Text.Lazy.Builder as TB
+import qualified Data.Text.Lazy.Builder.Int as TB
 import           System.Metrics (Sample, Value (..), sampleAll)
 import           System.Time.Extra (sleep)
 import           Text.Blaze.Html5 hiding (map)
-import           Text.Blaze.Html5.Attributes hiding (title)
+import           Text.Blaze.Html5.Attributes hiding (name, title)
 
 import           Snap.Blaze (blaze)
 import           Snap.Core (Snap, getRequest, route, rqParams, writeText)
@@ -113,54 +119,90 @@ runPrometheusServer tracerEnv endpoint@(Endpoint host port) = forever do
       _ -> writeText "No such a node!"
 
 type MetricName  = Text
-type MetricValue = Text
-type MetricsList = [(MetricName, MetricValue)]
 
 getMetricsFromNode
   :: TracerEnv
   -> NodeId
   -> AcceptedMetrics
   -> IO Text
-getMetricsFromNode tracerEnv nodeId acceptedMetrics =
+getMetricsFromNode TracerEnv{teConfig, teMetricsHelp} nodeId acceptedMetrics =
   readTVarIO acceptedMetrics >>=
     (\case
         Nothing ->
           return "No such a node!"
         Just (ekgStore, _) ->
-          sampleAll ekgStore <&> renderListOfMetrics . getListOfMetrics
+          sampleAll ekgStore <&> TL.toStrict . renderExpositionFromSample metricsComp teMetricsHelp
     ) . M.lookup nodeId
- where
-  getListOfMetrics :: Sample -> MetricsList
-  getListOfMetrics =
-      metricsCompatibility
-      . filter (not . T.null . fst)
-      . map metricsWeNeed
-      . HM.toList
-
-  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.
-
-  renderListOfMetrics :: MetricsList -> Text
-  renderListOfMetrics [] = "No metrics were received from this node."
-  renderListOfMetrics mList = T.intercalate "\n" $
-    map (\(mName, mValue) -> prepareName mName <> " " <> mValue) mList
-
-  prepareName =
-      T.filter (`elem` (['0'..'9'] ++ ['a'..'z'] ++ ['A'..'Z'] ++ ['_']))
-    . T.replace " " "_"
-    . T.replace "-" "_"
-    . T.replace "." "_"
-
-  metricsCompatibility :: MetricsList -> MetricsList
-  metricsCompatibility metricsList =
-      case metricsComp (teConfig tracerEnv) of
-        Nothing -> metricsList
-        Just mmap -> foldl  (\ accu p'@(mn,mv) -> case M.lookup mn mmap of
-                                                Nothing -> p' : accu
-                                                Just rep -> p' : (rep,mv) : accu)
-                            []
-                            metricsList
+  where
+    TracerConfig{metricsComp} = teConfig
+
+renderExpositionFromSample
+  :: Maybe (M.Map MetricName MetricName)
+  -> [(MetricName, Builder)]
+  -> Sample
+  -> TL.Text
+renderExpositionFromSample renameMap helpTextDict =
+  TB.toLazyText . (`mappend` builderEOF) . HM.foldlWithKey' buildMetric mempty
+  where
+    buildHelpText :: MetricName -> (Builder -> Builder)
+    buildHelpText
+      | null helpTextDict = const mempty
+      | otherwise =
+          let
+            buildHelp :: Builder -> Builder -> Builder
+            buildHelp h n =
+              TB.fromText "# HELP " `mappend` (n `mappend` (TB.singleton ' ' `mappend` (h `mappend` TB.singleton '\n')))
+          in  \name -> maybe (const mempty) (buildHelp . snd) $ find ((`T.isInfixOf` name) . fst) helpTextDict
+
+    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 "." "_"
+
+    buildMetric :: TB.Builder -> MetricName -> Value -> TB.Builder
+    buildMetric acc mName mValue =
+      acc `mappend` (buildHelpText mName builderName `mappend`
+        case mValue of
+          Counter c -> buildTypeAnn builderCounter
+                        `mappend` buildVal (TB.decimal c)
+          Gauge g   -> buildTypeAnn builderGauge
+                        `mappend` buildVal (TB.decimal g)
+          Label l
+            | Just ('{', _) <- T.uncons l
+                        -> buildTypeAnn builderInfo `mappend` (builderName `mappend` (TB.fromText l `mappend` TB.singleton '\n'))
+            | otherwise -> buildVal (TB.fromText l)
+          _         -> mempty
+      )
+      where
+        builderName = TB.fromText $ prepareName $ replaceName mName
+        buildTypeAnn t =
+          TB.fromText "# TYPE " `mappend` (builderName `mappend` (t `mappend` TB.singleton '\n'))
+        buildVal v =
+          builderName `mappend` (TB.singleton ' ' `mappend` (v `mappend` TB.singleton '\n'))
+
+builderGauge, builderCounter, builderInfo, builderEOF :: Builder
+builderGauge    = TB.fromText " gauge"
+builderCounter  = TB.fromText " counter"
+builderInfo     = TB.fromText " info"
+builderEOF      = TB.fromText "# EOF\n"
+
+{-
+
+TODO:
+
+_contentHeader :: Text
+_contentHeader = "Content-Type: text/plain; charset=utf-8"
+_contentHeader = "Content-Type: text/plain; version=0.0.4; charset=utf-8"
+
+-- Achtung! Nur wenn im Accept-header!
+_contentHeader = "application/openmetrics-text; version=1.0.0; charset=utf-8"
+
+-}

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

@@ -1,7 +1,9 @@
 {- HLINT ignore "Avoid lambda" -}
 
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 -- | This top-level module is used by 'cardano-tracer' app.
 module Cardano.Tracer.Run
@@ -33,11 +35,16 @@ import           Control.Concurrent.Extra (newLock)
 #if RTVIEW
 import           Control.Concurrent.STM.TVar (newTVarIO)
 #endif
+import           Control.Exception (SomeException, try)
 import           Control.Monad
+import           Data.Aeson (decodeFileStrict')
 import           Data.Foldable (for_)
 #if !RTVIEW
 import           Data.Maybe (isJust)
 #endif
+import qualified Data.Map.Strict as M (Map, filter, toList)
+import           Data.Text as T (Text, null)
+import           Data.Text.Lazy.Builder as TB (Builder, fromText)
 
 -- | Top-level run function, called by 'cardano-tracer' app.
 runCardanoTracer :: TracerParams -> IO ()
@@ -92,6 +99,8 @@ doRunCardanoTracer config rtViewStateDir tr protocolsBrake dpRequestors = do
   connectedNodes      <- initConnectedNodes
   connectedNodesNames <- initConnectedNodesNames
   acceptedMetrics <- initAcceptedMetrics
+  mHelp               <- loadMetricsHelp $ metricsHelp config
+
 #if RTVIEW
   savedTO <- initSavedTraceObjects
 
@@ -129,6 +138,7 @@ doRunCardanoTracer config rtViewStateDir tr protocolsBrake dpRequestors = do
         , teReforwardTraceObjects = reforwardTraceObject
         , teRegistry              = registry
         , teStateDir              = rtViewStateDir
+        , teMetricsHelp           = mHelp
         }
 
       tracerEnvRTView :: TracerEnvRTView
@@ -162,3 +172,12 @@ doRunCardanoTracer config rtViewStateDir tr protocolsBrake dpRequestors = do
     , runRTView         tracerEnv tracerEnvRTView
 #endif
     ]
+
+loadMetricsHelp :: Maybe FilePath -> IO [(Text, Builder)]
+loadMetricsHelp Nothing  = pure []
+loadMetricsHelp (Just f) = do
+  result :: Either SomeException (Maybe (M.Map Text Text))
+    <- try (decodeFileStrict' f)
+  pure $ case result of
+    Left{}    -> []
+    Right m   -> maybe [] (M.toList . fmap TB.fromText . M.filter (not . T.null)) m

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

@@ -80,6 +80,7 @@ launchAcceptorsSimple mode localSock dpName = do
         , teReforwardTraceObjects = \_-> pure ()
         , teRegistry              = registry
         , teStateDir              = Nothing
+        , teMetricsHelp           = []
         }
 
       tracerEnvRTView :: TracerEnvRTView
@@ -113,6 +114,7 @@ launchAcceptorsSimple mode localSock dpName = do
     , rotation       = Nothing
     , verbosity      = Just Minimum
     , metricsComp    = Nothing
+    , metricsHelp    = Nothing
     , hasForwarding  = Nothing
     , resourceFreq   = Nothing
     }