diff --git a/cardano-tracer/src/Cardano/Tracer/Configuration.hs b/cardano-tracer/src/Cardano/Tracer/Configuration.hs index 5dc607b1a1b..5198d4db3ae 100644 --- a/cardano-tracer/src/Cardano/Tracer/Configuration.hs +++ b/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) diff --git a/cardano-tracer/src/Cardano/Tracer/Environment.hs b/cardano-tracer/src/Cardano/Tracer/Environment.hs index 0ced2f87650..a2e01b0226d 100644 --- a/cardano-tracer/src/Cardano/Tracer/Environment.hs +++ b/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 diff --git a/cardano-tracer/src/Cardano/Tracer/Handlers/Metrics/Prometheus.hs b/cardano-tracer/src/Cardano/Tracer/Handlers/Metrics/Prometheus.hs index 4290e17a8da..575e2a22a8e 100644 --- a/cardano-tracer/src/Cardano/Tracer/Handlers/Metrics/Prometheus.hs +++ b/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" + +-} diff --git a/cardano-tracer/src/Cardano/Tracer/Run.hs b/cardano-tracer/src/Cardano/Tracer/Run.hs index ddd1d03edc8..4488d0038e0 100644 --- a/cardano-tracer/src/Cardano/Tracer/Run.hs +++ b/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 diff --git a/cardano-tracer/test/Cardano/Tracer/Test/Acceptor.hs b/cardano-tracer/test/Cardano/Tracer/Test/Acceptor.hs index 7c73562a204..e89b8a76dbe 100644 --- a/cardano-tracer/test/Cardano/Tracer/Test/Acceptor.hs +++ b/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 }