{-# LANGUAGE TemplateHaskell #-}

module Tendermint.SDK.BaseApp.Metrics.Prometheus
  (
    -- | Config and Setup
    MetricsScrapingConfig(..)
  , prometheusPort
  , MetricsState(..)
  , metricsRegistry
  , metricsCounters
  , metricsHistograms
  , PrometheusEnv(..)
  , envMetricsState
  , envMetricsScrapingConfig
  , emptyState
  , forkMetricsServer

  -- * Utils
  , mkPrometheusMetricId
  , metricIdStorable
  , countToIdentifier
  , histogramToIdentifier

  -- * Eval
  , evalWithMetrics
  , evalNothing
  , evalMetrics
  ) where

import           Control.Arrow                                 ((***))
import           Control.Concurrent                            (ThreadId,
                                                                forkIO)
import           Control.Concurrent.MVar                       (MVar,
                                                                modifyMVar_,
                                                                newMVar)
import           Control.Lens                                  (makeLenses)
import           Control.Monad.IO.Class                        (MonadIO, liftIO)
import           Data.Map.Strict                               (Map, insert)
import qualified Data.Map.Strict                               as Map
import           Data.String                                   (IsString,
                                                                fromString)
import           Data.Text                                     (Text)
import qualified Data.Text                                     as Text
import           Data.Time                                     (diffUTCTime,
                                                                getCurrentTime)
import           Polysemy                                      (Embed, Member,
                                                                Sem, interpretH,
                                                                pureT, raise,
                                                                runT)
import           Polysemy.Reader                               (Reader (..),
                                                                ask)
import qualified System.Metrics.Prometheus.Concurrent.Registry as Registry
import qualified System.Metrics.Prometheus.Http.Scrape         as Http
import qualified System.Metrics.Prometheus.Metric.Counter      as Counter
import qualified System.Metrics.Prometheus.Metric.Histogram    as Histogram
import qualified System.Metrics.Prometheus.MetricId            as MetricId
import           Tendermint.SDK.BaseApp.Metrics                (CountName (..), HistogramName (..),
                                                                Metrics (..))
--------------------------------------------------------------------------------
-- Metrics Types
--------------------------------------------------------------------------------

-- | Core metrics state
type MetricsMap a = Map (Text, MetricId.Labels) a

data MetricsState = MetricsState
  { MetricsState -> Registry
_metricsRegistry   :: Registry.Registry
  , MetricsState -> MVar (MetricsMap Counter)
_metricsCounters   :: MVar (MetricsMap Counter.Counter)
  , MetricsState -> MVar (MetricsMap Histogram)
_metricsHistograms :: MVar (MetricsMap Histogram.Histogram)
  }
makeLenses ''MetricsState

-- | Intermediary prometheus registry index key
data MetricIdentifier = MetricIdentifier
  { MetricIdentifier -> Text
metricIdName         :: Text
  , MetricIdentifier -> Labels
metricIdLabels       :: MetricId.Labels
  , MetricIdentifier -> [Double]
metricIdHistoBuckets :: [Double]
  }

instance IsString MetricIdentifier where
  fromString :: String -> MetricIdentifier
fromString s :: String
s = Text -> Labels -> [Double] -> MetricIdentifier
MetricIdentifier (String -> Text
forall a. IsString a => String -> a
fromString String
s) Labels
forall a. Monoid a => a
mempty [Double]
forall a. Monoid a => a
mempty

fixMetricName :: Text -> Text
fixMetricName :: Text -> Text
fixMetricName = (Char -> Char) -> Text -> Text
Text.map Char -> Char
fixer
  where fixer :: Char -> Char
fixer c :: Char
c = if Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
validChars then Char
c else '_'
        validChars :: String
validChars = ['a'..'z'] String -> String -> String
forall a. [a] -> [a] -> [a]
++ ['A'..'Z'] String -> String -> String
forall a. [a] -> [a] -> [a]
++ ['0'..'9'] String -> String -> String
forall a. [a] -> [a] -> [a]
++ "_"

-- indexes

countToIdentifier :: CountName -> MetricIdentifier
countToIdentifier :: CountName -> MetricIdentifier
countToIdentifier (CountName name :: Text
name labels :: [(Text, Text)]
labels) = MetricIdentifier :: Text -> Labels -> [Double] -> MetricIdentifier
MetricIdentifier
  { metricIdName :: Text
metricIdName = Text -> Text
fixMetricName Text
name
  , metricIdLabels :: Labels
metricIdLabels = [(Text, Text)] -> Labels
MetricId.fromList [(Text, Text)]
labels
  , metricIdHistoBuckets :: [Double]
metricIdHistoBuckets = []
  }

histogramToIdentifier :: HistogramName -> MetricIdentifier
histogramToIdentifier :: HistogramName -> MetricIdentifier
histogramToIdentifier (HistogramName name :: Text
name labels :: [(Text, Text)]
labels buckets :: [Double]
buckets) = MetricIdentifier :: Text -> Labels -> [Double] -> MetricIdentifier
MetricIdentifier
  { metricIdName :: Text
metricIdName = Text -> Text
fixMetricName Text
name
  , metricIdLabels :: Labels
metricIdLabels = [(Text, Text)] -> Labels
MetricId.fromList [(Text, Text)]
labels
  , metricIdHistoBuckets :: [Double]
metricIdHistoBuckets = [Double]
buckets
  }

-- | Prometheus registry index key
mkPrometheusMetricId :: MetricIdentifier -> MetricId.MetricId
mkPrometheusMetricId :: MetricIdentifier -> MetricId
mkPrometheusMetricId MetricIdentifier{..} =
  Name -> Labels -> MetricId
MetricId.MetricId (Text -> Name
MetricId.Name Text
metricIdName) Labels
metricIdLabels

-- | Index key for storing metrics
metricIdStorable :: MetricIdentifier -> (Text, MetricId.Labels)
metricIdStorable :: MetricIdentifier -> (Text, Labels)
metricIdStorable c :: MetricIdentifier
c = (Text -> Text
fixMetricName (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ MetricIdentifier -> Text
metricIdName MetricIdentifier
c, Labels -> Labels
fixMetricLabels (Labels -> Labels) -> Labels -> Labels
forall a b. (a -> b) -> a -> b
$ MetricIdentifier -> Labels
metricIdLabels MetricIdentifier
c)
  where fixMetricLabels :: Labels -> Labels
fixMetricLabels =
          [(Text, Text)] -> Labels
MetricId.fromList ([(Text, Text)] -> Labels)
-> (Labels -> [(Text, Text)]) -> Labels -> Labels
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
          ((Text, Text) -> (Text, Text)) -> [(Text, Text)] -> [(Text, Text)]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text
fixMetricName (Text -> Text) -> (Text -> Text) -> (Text, Text) -> (Text, Text)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** Text -> Text
fixMetricName) ([(Text, Text)] -> [(Text, Text)])
-> (Labels -> [(Text, Text)]) -> Labels -> [(Text, Text)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
          Labels -> [(Text, Text)]
MetricId.toList


--------------------------------------------------------------------------------
-- Config
--------------------------------------------------------------------------------

-- | Core metrics config
data MetricsScrapingConfig = MetricsScrapingConfig
  { MetricsScrapingConfig -> Int
_prometheusPort :: Int
  }

makeLenses ''MetricsScrapingConfig

data PrometheusEnv = PrometheusEnv
  { PrometheusEnv -> MetricsState
_envMetricsState          :: MetricsState
  , PrometheusEnv -> MetricsScrapingConfig
_envMetricsScrapingConfig :: MetricsScrapingConfig
  }

makeLenses ''PrometheusEnv

emptyState :: IO MetricsState
emptyState :: IO MetricsState
emptyState = do
  MVar (MetricsMap Counter)
counters <- MetricsMap Counter -> IO (MVar (MetricsMap Counter))
forall a. a -> IO (MVar a)
newMVar MetricsMap Counter
forall k a. Map k a
Map.empty
  MVar (MetricsMap Histogram)
histos <- MetricsMap Histogram -> IO (MVar (MetricsMap Histogram))
forall a. a -> IO (MVar a)
newMVar MetricsMap Histogram
forall k a. Map k a
Map.empty
  Registry
registry <- IO Registry
Registry.new
  MetricsState -> IO MetricsState
forall (m :: * -> *) a. Monad m => a -> m a
return (MetricsState -> IO MetricsState)
-> MetricsState -> IO MetricsState
forall a b. (a -> b) -> a -> b
$ Registry
-> MVar (MetricsMap Counter)
-> MVar (MetricsMap Histogram)
-> MetricsState
MetricsState Registry
registry MVar (MetricsMap Counter)
counters MVar (MetricsMap Histogram)
histos

forkMetricsServer
  :: MonadIO m
  => PrometheusEnv
  -> m ThreadId
forkMetricsServer :: PrometheusEnv -> m ThreadId
forkMetricsServer metCfg :: PrometheusEnv
metCfg = IO ThreadId -> m ThreadId
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ThreadId -> m ThreadId) -> IO ThreadId -> m ThreadId
forall a b. (a -> b) -> a -> b
$
  let PrometheusEnv{..} = PrometheusEnv
metCfg
      port :: Int
port = MetricsScrapingConfig -> Int
_prometheusPort (MetricsScrapingConfig -> Int) -> MetricsScrapingConfig -> Int
forall a b. (a -> b) -> a -> b
$ MetricsScrapingConfig
_envMetricsScrapingConfig
      MetricsState{..} = MetricsState
_envMetricsState
  in IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Int -> Path -> IO RegistrySample -> IO ()
forall (m :: * -> *).
MonadIO m =>
Int -> Path -> IO RegistrySample -> m ()
Http.serveHttpTextMetrics Int
port ["metrics"] (Registry -> IO RegistrySample
Registry.sample Registry
_metricsRegistry)

--------------------------------------------------------------------------------
-- eval
--------------------------------------------------------------------------------

evalWithMetrics
  :: Member (Embed IO) r
  => Member (Reader (Maybe PrometheusEnv)) r
  => Sem (Metrics ': r) a
  -> Sem r a
evalWithMetrics :: Sem (Metrics : r) a -> Sem r a
evalWithMetrics action :: Sem (Metrics : r) a
action = do
  Maybe PrometheusEnv
mCfg <- Sem r (Maybe PrometheusEnv)
forall i (r :: [(* -> *) -> * -> *]).
MemberWithError (Reader i) r =>
Sem r i
ask
  case Maybe PrometheusEnv
mCfg of
    Nothing  -> Sem (Metrics : r) a -> Sem r a
forall (r :: [(* -> *) -> * -> *]) a.
Sem (Metrics : r) a -> Sem r a
evalNothing Sem (Metrics : r) a
action
    Just cfg :: PrometheusEnv
cfg -> MetricsState -> Sem (Metrics : r) a -> Sem r a
forall (r :: [(* -> *) -> * -> *]) a.
Member (Embed IO) r =>
MetricsState -> Sem (Metrics : r) a -> Sem r a
evalMetrics (PrometheusEnv -> MetricsState
_envMetricsState PrometheusEnv
cfg) Sem (Metrics : r) a
action

evalNothing
  :: Sem (Metrics ': r) a
  -> Sem r a
evalNothing :: Sem (Metrics : r) a -> Sem r a
evalNothing = do
  (forall x (m :: * -> *). Metrics m x -> Tactical Metrics m r x)
-> Sem (Metrics : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
(forall x (m :: * -> *). e m x -> Tactical e m r x)
-> Sem (e : r) a -> Sem r a
interpretH (\case
    IncCount _ -> () -> Tactical Metrics m r ()
forall a (e :: (* -> *) -> * -> *) (m :: * -> *)
       (r :: [(* -> *) -> * -> *]).
a -> Tactical e m r a
pureT ()
    WithTimer _ action -> do
      Sem (Metrics : r) (f x)
a <- m x
-> Sem (Tactics f m (Metrics : r) : r) (Sem (Metrics : r) (f x))
forall (m :: * -> *) a (e :: (* -> *) -> * -> *) (f :: * -> *)
       (r :: [(* -> *) -> * -> *]).
m a -> Sem (WithTactics e f m r) (Sem (e : r) (f a))
runT m x
action
      Sem r (f x) -> Sem (Tactics f m (Metrics : r) : r) (f x)
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
Sem r a -> Sem (e : r) a
raise (Sem r (f x) -> Sem (Tactics f m (Metrics : r) : r) (f x))
-> Sem r (f x) -> Sem (Tactics f m (Metrics : r) : r) (f x)
forall a b. (a -> b) -> a -> b
$ Sem (Metrics : r) (f x) -> Sem r (f x)
forall (r :: [(* -> *) -> * -> *]) a.
Sem (Metrics : r) a -> Sem r a
evalNothing Sem (Metrics : r) (f x)
a
    )

-- | Increments existing count, if it doesn't exist, creates a new
-- | counter and increments it.
evalMetrics
  :: Member (Embed IO) r
  => MetricsState
  -> Sem (Metrics ': r) a
  -> Sem r a
evalMetrics :: MetricsState -> Sem (Metrics : r) a -> Sem r a
evalMetrics state :: MetricsState
state@MetricsState{..} = do
 (forall x (m :: * -> *). Metrics m x -> Tactical Metrics m r x)
-> Sem (Metrics : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
(forall x (m :: * -> *). e m x -> Tactical e m r x)
-> Sem (e : r) a -> Sem r a
interpretH (\case
    IncCount ctrName -> do
      let c :: MetricIdentifier
c@MetricIdentifier{..} = CountName -> MetricIdentifier
countToIdentifier CountName
ctrName
          cid :: (Text, Labels)
cid = MetricIdentifier -> (Text, Labels)
metricIdStorable MetricIdentifier
c
          cMetricIdName :: Name
cMetricIdName = Text -> Name
MetricId.Name Text
metricIdName
      IO () -> Sem (WithTactics Metrics f m r) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Sem (WithTactics Metrics f m r) ())
-> IO () -> Sem (WithTactics Metrics f m r) ()
forall a b. (a -> b) -> a -> b
$ MVar (MetricsMap Counter)
-> (MetricsMap Counter -> IO (MetricsMap Counter)) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (MetricsMap Counter)
_metricsCounters ((MetricsMap Counter -> IO (MetricsMap Counter)) -> IO ())
-> (MetricsMap Counter -> IO (MetricsMap Counter)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \counterMap :: MetricsMap Counter
counterMap ->
        case (Text, Labels) -> MetricsMap Counter -> Maybe Counter
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Text, Labels)
cid MetricsMap Counter
counterMap of
          Nothing -> do
            Counter
newCtr <- IO Counter -> IO Counter
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Counter -> IO Counter) -> IO Counter -> IO Counter
forall a b. (a -> b) -> a -> b
$
              Name -> Labels -> Registry -> IO Counter
Registry.registerCounter Name
cMetricIdName Labels
metricIdLabels Registry
_metricsRegistry
            let newCounterMap :: MetricsMap Counter
newCounterMap = (Text, Labels)
-> Counter -> MetricsMap Counter -> MetricsMap Counter
forall k a. Ord k => k -> a -> Map k a -> Map k a
insert (Text, Labels)
cid Counter
newCtr MetricsMap Counter
counterMap
            IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Counter -> IO ()
Counter.inc Counter
newCtr
            MetricsMap Counter -> IO (MetricsMap Counter)
forall (f :: * -> *) a. Applicative f => a -> f a
pure MetricsMap Counter
newCounterMap
          Just ctr :: Counter
ctr -> do
            IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Counter -> IO ()
Counter.inc Counter
ctr
            MetricsMap Counter -> IO (MetricsMap Counter)
forall (f :: * -> *) a. Applicative f => a -> f a
pure MetricsMap Counter
counterMap
      () -> Tactical Metrics m r ()
forall a (e :: (* -> *) -> * -> *) (m :: * -> *)
       (r :: [(* -> *) -> * -> *]).
a -> Tactical e m r a
pureT ()

    -- Updates a histogram with the time it takes to do an action
    -- If histogram doesn't exist, creates a new one and observes it.
    WithTimer histName action -> do
      UTCTime
start <- IO UTCTime -> Sem (WithTactics Metrics f m r) UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO UTCTime -> Sem (WithTactics Metrics f m r) UTCTime)
-> IO UTCTime -> Sem (WithTactics Metrics f m r) UTCTime
forall a b. (a -> b) -> a -> b
$ IO UTCTime
getCurrentTime
      Sem (Metrics : r) (f x)
a <- m x -> Sem (WithTactics Metrics f m r) (Sem (Metrics : r) (f x))
forall (m :: * -> *) a (e :: (* -> *) -> * -> *) (f :: * -> *)
       (r :: [(* -> *) -> * -> *]).
m a -> Sem (WithTactics e f m r) (Sem (e : r) (f a))
runT m x
action
      UTCTime
end <- IO UTCTime -> Sem (WithTactics Metrics f m r) UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO UTCTime -> Sem (WithTactics Metrics f m r) UTCTime)
-> IO UTCTime -> Sem (WithTactics Metrics f m r) UTCTime
forall a b. (a -> b) -> a -> b
$ IO UTCTime
getCurrentTime
      let time :: Double
time = NominalDiffTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (UTCTime
end UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` UTCTime
start)
      MetricsState
-> HistogramName -> Double -> Sem (WithTactics Metrics f m r) ()
forall (m :: * -> *).
MonadIO m =>
MetricsState -> HistogramName -> Double -> m ()
observeHistogram MetricsState
state HistogramName
histName Double
time
      Sem r (f x) -> Sem (WithTactics Metrics f m r) (f x)
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
Sem r a -> Sem (e : r) a
raise (Sem r (f x) -> Sem (WithTactics Metrics f m r) (f x))
-> Sem r (f x) -> Sem (WithTactics Metrics f m r) (f x)
forall a b. (a -> b) -> a -> b
$ MetricsState -> Sem (Metrics : r) (f x) -> Sem r (f x)
forall (r :: [(* -> *) -> * -> *]) a.
Member (Embed IO) r =>
MetricsState -> Sem (Metrics : r) a -> Sem r a
evalMetrics MetricsState
state Sem (Metrics : r) (f x)
a
    )

-- | Updates a histogram with an observed value
observeHistogram :: MonadIO m => MetricsState -> HistogramName -> Double -> m ()
observeHistogram :: MetricsState -> HistogramName -> Double -> m ()
observeHistogram MetricsState{..} histName :: HistogramName
histName val :: Double
val = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  let h :: MetricIdentifier
h@MetricIdentifier{..} = HistogramName -> MetricIdentifier
histogramToIdentifier HistogramName
histName
      hid :: (Text, Labels)
hid = MetricIdentifier -> (Text, Labels)
metricIdStorable MetricIdentifier
h
      hMetricIdName :: Name
hMetricIdName = Text -> Name
MetricId.Name Text
metricIdName
  MVar (MetricsMap Histogram)
-> (MetricsMap Histogram -> IO (MetricsMap Histogram)) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (MetricsMap Histogram)
_metricsHistograms ((MetricsMap Histogram -> IO (MetricsMap Histogram)) -> IO ())
-> (MetricsMap Histogram -> IO (MetricsMap Histogram)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \histMap :: MetricsMap Histogram
histMap ->
    case (Text, Labels) -> MetricsMap Histogram -> Maybe Histogram
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Text, Labels)
hid MetricsMap Histogram
histMap of
      Nothing -> do
        Histogram
newHist <-
          Name -> Labels -> [Double] -> Registry -> IO Histogram
Registry.registerHistogram Name
hMetricIdName Labels
metricIdLabels [Double]
metricIdHistoBuckets Registry
_metricsRegistry
        let newHistMap :: MetricsMap Histogram
newHistMap = (Text, Labels)
-> Histogram -> MetricsMap Histogram -> MetricsMap Histogram
forall k a. Ord k => k -> a -> Map k a -> Map k a
insert (Text, Labels)
hid Histogram
newHist MetricsMap Histogram
histMap
        Double -> Histogram -> IO ()
Histogram.observe Double
val Histogram
newHist
        MetricsMap Histogram -> IO (MetricsMap Histogram)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MetricsMap Histogram -> IO (MetricsMap Histogram))
-> MetricsMap Histogram -> IO (MetricsMap Histogram)
forall a b. (a -> b) -> a -> b
$ MetricsMap Histogram
newHistMap
      Just hist :: Histogram
hist -> do
        Double -> Histogram -> IO ()
Histogram.observe Double
val Histogram
hist
        MetricsMap Histogram -> IO (MetricsMap Histogram)
forall (f :: * -> *) a. Applicative f => a -> f a
pure MetricsMap Histogram
histMap