module Cardano.Logging.Prometheus.Exposition
  ( MetricName
  , renderExpositionFromSample
  , renderExpositionFromSampleWith
  ) where

import           Data.Char
import           Data.Foldable (asum)
import qualified Data.HashMap.Strict as HM
import           Data.List (find)
import           Data.Maybe
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           System.Metrics (Sample, Value (..))


type MetricName = Text


renderExpositionFromSample :: Bool -> Sample -> TL.Text
renderExpositionFromSample :: Bool -> Sample -> Text
renderExpositionFromSample = [(Text, Builder)] -> Bool -> Sample -> Text
renderExpositionFromSampleWith []

renderExpositionFromSampleWith
  :: [(MetricName, Builder)]
  -> Bool
  -> Sample
  -> TL.Text
renderExpositionFromSampleWith :: [(Text, Builder)] -> Bool -> Sample -> Text
renderExpositionFromSampleWith [(Text, Builder)]
helpTextDict Bool
noSuffixes =
  Builder -> Text
TB.toLazyText (Builder -> Text) -> (Sample -> Builder) -> Sample -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
buildEOF) (Builder -> Builder) -> (Sample -> Builder) -> Sample -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Builder -> Text -> Value -> Builder)
-> Builder -> Sample -> Builder
forall a k v. (a -> k -> v -> a) -> a -> HashMap k v -> a
HM.foldlWithKey' Builder -> Text -> Value -> Builder
buildMetric Builder
forall a. Monoid a => a
mempty
  where
    buildHelpText :: MetricName -> (Builder -> Builder)
    buildHelpText :: Text -> Builder -> Builder
buildHelpText Text
name = (Builder -> Builder)
-> ((Text, Builder) -> Builder -> Builder)
-> Maybe (Text, Builder)
-> Builder
-> Builder
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
      (Builder -> Builder -> Builder
forall a b. a -> b -> a
const Builder
forall a. Monoid a => a
mempty)
      (Builder -> Builder -> Builder
buildHelp (Builder -> Builder -> Builder)
-> ((Text, Builder) -> Builder)
-> (Text, Builder)
-> Builder
-> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Builder) -> Builder
forall a b. (a, b) -> b
snd)
      (((Text, Builder) -> Bool)
-> [(Text, Builder)] -> Maybe (Text, Builder)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Text -> Text -> Bool
`T.isInfixOf` Text
name) (Text -> Bool)
-> ((Text, Builder) -> Text) -> (Text, Builder) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Builder) -> Text
forall a b. (a, b) -> a
fst) [(Text, Builder)]
helpTextDict)

    -- implements the metricsNoSuffix config option
    -- must strip all suffixes as per: trace-dispatcher/src/Cardano/Logging/Tracer/EKG.hs > ekgTracer > setIt
    stripSuffix :: MetricName -> MetricName
    stripSuffix :: Text -> Text
stripSuffix
      | Bool
noSuffixes = \Text
name -> Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
name (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ [Maybe Text] -> Maybe Text
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum ([Maybe Text] -> Maybe Text) -> [Maybe Text] -> Maybe Text
forall a b. (a -> b) -> a -> b
$ (Text -> Maybe Text) -> [Text] -> [Maybe Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text -> Maybe Text
`T.stripSuffix` Text
name) [Text
"_int", Text
"_counter", Text
"_real"]
      | Bool
otherwise  = Text -> Text
forall a. a -> a
id

    prepareName :: MetricName -> MetricName
    prepareName :: Text -> Text
prepareName =
        (Char -> Bool) -> Text -> Text
T.filter (\Char
c -> Char -> Bool
isAsciiLower Char
c Bool -> Bool -> Bool
|| Char -> Bool
isAsciiUpper Char
c Bool -> Bool -> Bool
|| Char -> Bool
isDigit Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_')
      (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
" " Text
"_"
      (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"-" Text
"_"
      (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"." Text
"_"

    -- the help annotation line
    buildHelp :: Builder -> Builder -> Builder
    buildHelp :: Builder -> Builder -> Builder
buildHelp Builder
h Builder
n =
      Text -> Builder
TB.fromText Text
"# HELP " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
n Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
space Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
h Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
newline

    buildMetric :: TB.Builder -> MetricName -> Value -> TB.Builder
    buildMetric :: Builder -> Text -> Value -> Builder
buildMetric Builder
acc Text
mName Value
mValue =
      Builder
acc Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> case Value
mValue of
        Counter Int64
c -> Builder -> Builder
annotate Builder
buildCounter Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder -> Builder -> Builder
buildVal Builder
space  (Int64 -> Builder
forall a. Integral a => a -> Builder
TB.decimal Int64
c)
        Gauge Int64
g   -> Builder -> Builder
annotate Builder
buildGauge   Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder -> Builder -> Builder
buildVal Builder
space  (Int64 -> Builder
forall a. Integral a => a -> Builder
TB.decimal Int64
g)
        Label Text
l
          | Just (Char
'{', Text
_) <- Text -> Maybe (Char, Text)
T.uncons Text
l
                  -> Builder -> Builder
annotate Builder
buildInfo    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder -> Builder -> Builder
buildVal Builder
forall a. Monoid a => a
mempty (Text -> Builder
TB.fromText Text
l)
          | Bool
otherwise
                  -> Builder
helpAnnotation        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder -> Builder -> Builder
buildVal Builder
space  (Text -> Builder
TB.fromText Text
l)
        Value
_         -> Builder
forall a. Monoid a => a
mempty
      where
        helpAnnotation :: Builder
helpAnnotation =
          Text -> Builder -> Builder
buildHelpText Text
mName Builder
buildName

        -- annotates a metric in the order TYPE, UNIT, HELP
        -- TODO: UNIT annotation
        annotate :: Builder -> Builder
annotate Builder
annType =
          Builder -> Builder
buildTypeAnn Builder
annType Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
helpAnnotation

        -- the metric name for exposition
        buildName :: Builder
buildName =
          Text -> Builder
TB.fromText (Text -> Builder) -> Text -> Builder
forall a b. (a -> b) -> a -> b
$ Text -> Text
prepareName (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
stripSuffix Text
mName

        -- the type annotation line
        buildTypeAnn :: Builder -> Builder
buildTypeAnn Builder
t =
          Text -> Builder
TB.fromText Text
"# TYPE " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
buildName Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
t Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
newline

        -- the actual metric line, optional spacing after name, because of labels: 'metric_name{label_value="foo"} 1'
        buildVal :: Builder -> Builder -> Builder
buildVal Builder
spacing Builder
v =
          Builder
buildName Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
spacing Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
v Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
newline

buildGauge, buildCounter, buildInfo, buildEOF, newline, space :: Builder
buildGauge :: Builder
buildGauge    = Text -> Builder
TB.fromText Text
" gauge"
buildCounter :: Builder
buildCounter  = Text -> Builder
TB.fromText Text
" counter"
buildInfo :: Builder
buildInfo     = Text -> Builder
TB.fromText Text
" info"
buildEOF :: Builder
buildEOF      = Text -> Builder
TB.fromText Text
"# EOF\n"
newline :: Builder
newline       = Char -> Builder
TB.singleton Char
'\n'
space :: Builder
space         = Char -> Builder
TB.singleton Char
' '