{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Cardano.Logging.Tracer.EKG (
  ekgTracer
) where

import           Cardano.Logging.DocuGenerator
import           Cardano.Logging.Types
import           Cardano.Logging.Utils (showTReal)

import           Control.Concurrent.MVar
import           Control.Monad.IO.Class (MonadIO, liftIO)
import qualified Control.Tracer as T
import qualified Data.HashMap.Strict as Map
import           Data.Maybe (fromMaybe)
import           Data.Text (Text, intercalate)
import qualified System.Metrics as Metrics
import qualified System.Metrics.Counter as Counter
import qualified System.Metrics.Gauge as Gauge
import qualified System.Metrics.Label as Label


-- Using a hashmap, as metrics names typically contain long common prefixes, which is suboptimal for key lookup based on Ord
type Map = Map.HashMap

-- | It is mandatory to construct only one standard tracer in any application!
-- Throwing away a standard tracer and using a new one will result in an exception
ekgTracer :: MonadIO m => TraceConfig -> Metrics.Store -> m (Trace m FormattedMessage)
ekgTracer :: forall (m :: * -> *).
MonadIO m =>
TraceConfig -> Store -> m (Trace m FormattedMessage)
ekgTracer TraceConfig{Maybe Text
tcMetricsPrefix :: Maybe Text
tcMetricsPrefix :: TraceConfig -> Maybe Text
tcMetricsPrefix} Store
store = IO (Trace m FormattedMessage) -> m (Trace m FormattedMessage)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Trace m FormattedMessage) -> m (Trace m FormattedMessage))
-> IO (Trace m FormattedMessage) -> m (Trace m FormattedMessage)
forall a b. (a -> b) -> a -> b
$ do
    MVar (HashMap Text Gauge)
rgsGauges   <- HashMap Text Gauge -> IO (MVar (HashMap Text Gauge))
forall a. a -> IO (MVar a)
newMVar HashMap Text Gauge
forall k v. HashMap k v
Map.empty
    MVar (HashMap Text Label)
rgsLabels   <- HashMap Text Label -> IO (MVar (HashMap Text Label))
forall a. a -> IO (MVar a)
newMVar HashMap Text Label
forall k v. HashMap k v
Map.empty
    MVar (HashMap Text Counter)
rgsCounters <- HashMap Text Counter -> IO (MVar (HashMap Text Counter))
forall a. a -> IO (MVar a)
newMVar HashMap Text Counter
forall k v. HashMap k v
Map.empty
    Trace m FormattedMessage -> IO (Trace m FormattedMessage)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Trace m FormattedMessage -> IO (Trace m FormattedMessage))
-> Trace m FormattedMessage -> IO (Trace m FormattedMessage)
forall a b. (a -> b) -> a -> b
$ Tracer m (LoggingContext, Either TraceControl FormattedMessage)
-> Trace m FormattedMessage
forall (m :: * -> *) a.
Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
Trace (Tracer m (LoggingContext, Either TraceControl FormattedMessage)
 -> Trace m FormattedMessage)
-> Tracer m (LoggingContext, Either TraceControl FormattedMessage)
-> Trace m FormattedMessage
forall a b. (a -> b) -> a -> b
$ TracerA m (LoggingContext, Either TraceControl FormattedMessage) ()
-> Tracer m (LoggingContext, Either TraceControl FormattedMessage)
forall (m :: * -> *) a. TracerA m a () -> Tracer m a
T.arrow (TracerA
   m (LoggingContext, Either TraceControl FormattedMessage) ()
 -> Tracer m (LoggingContext, Either TraceControl FormattedMessage))
-> TracerA
     m (LoggingContext, Either TraceControl FormattedMessage) ()
-> Tracer m (LoggingContext, Either TraceControl FormattedMessage)
forall a b. (a -> b) -> a -> b
$ ((LoggingContext, Either TraceControl FormattedMessage) -> m ())
-> TracerA
     m (LoggingContext, Either TraceControl FormattedMessage) ()
forall (m :: * -> *) a.
Applicative m =>
(a -> m ()) -> TracerA m a ()
T.emit (((LoggingContext, Either TraceControl FormattedMessage) -> m ())
 -> TracerA
      m (LoggingContext, Either TraceControl FormattedMessage) ())
-> ((LoggingContext, Either TraceControl FormattedMessage) -> m ())
-> TracerA
     m (LoggingContext, Either TraceControl FormattedMessage) ()
forall a b. (a -> b) -> a -> b
$
      MVar (HashMap Text Gauge)
-> MVar (HashMap Text Label)
-> MVar (HashMap Text Counter)
-> (LoggingContext, Either TraceControl FormattedMessage)
-> m ()
forall (m :: * -> *).
MonadIO m =>
MVar (HashMap Text Gauge)
-> MVar (HashMap Text Label)
-> MVar (HashMap Text Counter)
-> (LoggingContext, Either TraceControl FormattedMessage)
-> m ()
output MVar (HashMap Text Gauge)
rgsGauges MVar (HashMap Text Label)
rgsLabels MVar (HashMap Text Counter)
rgsCounters
  where
    metricsPrefix :: Text
metricsPrefix = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
forall a. Monoid a => a
mempty Maybe Text
tcMetricsPrefix

    output :: MonadIO m =>
         MVar (Map Text Gauge.Gauge)
      -> MVar (Map Text Label.Label)
      -> MVar (Map Text Counter.Counter)
      -> (LoggingContext, Either TraceControl FormattedMessage)
      -> m ()
    output :: forall (m :: * -> *).
MonadIO m =>
MVar (HashMap Text Gauge)
-> MVar (HashMap Text Label)
-> MVar (HashMap Text Counter)
-> (LoggingContext, Either TraceControl FormattedMessage)
-> m ()
output MVar (HashMap Text Gauge)
rgsGauges MVar (HashMap Text Label)
rgsLabels MVar (HashMap Text Counter)
rgsCounters
      (LoggingContext
_, Right (FormattedMetrics [Metric]
m)) =
        IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ (Metric -> IO ()) -> [Metric] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
          (MVar (HashMap Text Gauge)
-> MVar (HashMap Text Label)
-> MVar (HashMap Text Counter)
-> Metric
-> IO ()
setIt MVar (HashMap Text Gauge)
rgsGauges MVar (HashMap Text Label)
rgsLabels MVar (HashMap Text Counter)
rgsCounters) [Metric]
m
    output MVar (HashMap Text Gauge)
_ MVar (HashMap Text Label)
_ MVar (HashMap Text Counter)
_ p :: (LoggingContext, Either TraceControl FormattedMessage)
p@(LoggingContext
_, Left TCDocument {}) =
      BackendConfig
-> (LoggingContext, Either TraceControl FormattedMessage) -> m ()
forall (m :: * -> *) a.
MonadIO m =>
BackendConfig -> (LoggingContext, Either TraceControl a) -> m ()
docIt BackendConfig
EKGBackend (LoggingContext, Either TraceControl FormattedMessage)
p
    output MVar (HashMap Text Gauge)
_ MVar (HashMap Text Label)
_ MVar (HashMap Text Counter)
_ (LoggingContext{}, Either TraceControl FormattedMessage
_) =
      () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    setIt ::
         MVar (Map Text Gauge.Gauge)
      -> MVar (Map Text Label.Label)
      -> MVar (Map Text Counter.Counter)
      -> Metric
      -> IO ()
    setIt :: MVar (HashMap Text Gauge)
-> MVar (HashMap Text Label)
-> MVar (HashMap Text Counter)
-> Metric
-> IO ()
setIt MVar (HashMap Text Gauge)
rgsGauges MVar (HashMap Text Label)
rgsLabels MVar (HashMap Text Counter)
rgsCounters = \case
        IntM Text
name Integer
theInt -> do
          let fullName :: Text
fullName = Text
metricsPrefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_int"
          Gauge
gauge <- MVar (HashMap Text Gauge)
-> (HashMap Text Gauge -> IO (HashMap Text Gauge, Gauge))
-> IO Gauge
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar (HashMap Text Gauge)
rgsGauges ((Text -> Store -> IO Gauge)
-> Text -> HashMap Text Gauge -> IO (HashMap Text Gauge, Gauge)
forall m.
(Text -> Store -> IO m) -> Text -> Map Text m -> IO (Map Text m, m)
setFunc Text -> Store -> IO Gauge
Metrics.createGauge Text
fullName)
          Gauge -> Int64 -> IO ()
Gauge.set Gauge
gauge (Integer -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
theInt)
        DoubleM Text
name Double
theDouble -> do
          let fullName :: Text
fullName = Text
metricsPrefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_real"
          Label
label <- MVar (HashMap Text Label)
-> (HashMap Text Label -> IO (HashMap Text Label, Label))
-> IO Label
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar (HashMap Text Label)
rgsLabels ((Text -> Store -> IO Label)
-> Text -> HashMap Text Label -> IO (HashMap Text Label, Label)
forall m.
(Text -> Store -> IO m) -> Text -> Map Text m -> IO (Map Text m, m)
setFunc Text -> Store -> IO Label
Metrics.createLabel Text
fullName)
          Label -> Text -> IO ()
Label.set Label
label (Double -> Text
forall a. RealFloat a => a -> Text
showTReal Double
theDouble)
        PrometheusM Text
name [(Text, Text)]
keyLabels -> do
          let fullName :: Text
fullName = Text
metricsPrefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name
          Label
label <- MVar (HashMap Text Label)
-> (HashMap Text Label -> IO (HashMap Text Label, Label))
-> IO Label
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar (HashMap Text Label)
rgsLabels ((Text -> Store -> IO Label)
-> Text -> HashMap Text Label -> IO (HashMap Text Label, Label)
forall m.
(Text -> Store -> IO m) -> Text -> Map Text m -> IO (Map Text m, m)
setFunc Text -> Store -> IO Label
Metrics.createLabel Text
fullName)
          Label -> Text -> IO ()
Label.set Label
label ([(Text, Text)] -> Text
presentPrometheusM [(Text, Text)]
keyLabels)
        CounterM Text
name Maybe Int
mbInt -> do
          let fullName :: Text
fullName = Text
metricsPrefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_counter"
          Counter
counter <- MVar (HashMap Text Counter)
-> (HashMap Text Counter -> IO (HashMap Text Counter, Counter))
-> IO Counter
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar (HashMap Text Counter)
rgsCounters ((Text -> Store -> IO Counter)
-> Text
-> HashMap Text Counter
-> IO (HashMap Text Counter, Counter)
forall m.
(Text -> Store -> IO m) -> Text -> Map Text m -> IO (Map Text m, m)
setFunc Text -> Store -> IO Counter
Metrics.createCounter Text
fullName)
          case Maybe Int
mbInt of
            Maybe Int
Nothing -> Counter -> IO ()
Counter.inc Counter
counter
            Just Int
i  -> Counter -> Int64 -> IO ()
Counter.add Counter
counter (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i)

    setFunc ::
         (Text -> Metrics.Store -> IO m)
      -> Text
      -> Map Text m
      -> IO (Map Text m, m)
    setFunc :: forall m.
(Text -> Store -> IO m) -> Text -> Map Text m -> IO (Map Text m, m)
setFunc Text -> Store -> IO m
createAction Text
name Map Text m
rgsMap =
        case Text -> Map Text m -> Maybe m
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup Text
name Map Text m
rgsMap of
          Just m
metric -> (Map Text m, m) -> IO (Map Text m, m)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map Text m
rgsMap, m
metric)
          Maybe m
Nothing -> do
            m
metric <- Text -> Store -> IO m
createAction Text
name Store
store
            let rgsMap' :: Map Text m
rgsMap' = Text -> m -> Map Text m -> Map Text m
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
Map.insert Text
name m
metric Map Text m
rgsMap
            (Map Text m, m) -> IO (Map Text m, m)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map Text m
rgsMap', m
metric)

    presentPrometheusM :: [(Text, Text)] -> Text
    presentPrometheusM :: [(Text, Text)] -> Text
presentPrometheusM =
      [Text] -> Text
label ([Text] -> Text)
-> ([(Text, Text)] -> [Text]) -> [(Text, Text)] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, Text) -> Text) -> [(Text, Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Text) -> Text
forall {a}. (Semigroup a, IsString a) => (a, a) -> a
pair
      where
        label :: [Text] -> Text
label [Text]
pairs = Text
"{" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
intercalate Text
"," [Text]
pairs Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"} 1"
        pair :: (a, a) -> a
pair (a
k, a
v) = a
k a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"=\"" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
v a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"\""