{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

-- |
-- Description : EventBackend for rendering events as Prometheus metrics
-- Copyright   : Copyright 2023 Shea Levy.
-- License     : Apache-2.0
-- Maintainer  : shea@shealevy.com
module Observe.Event.Render.Prometheus where

import Control.Exception
import Data.Foldable
import Data.IORef
import Data.Map
import Data.Traversable
import Observe.Event.Backend
import System.Metrics.Prometheus.Concurrent.Registry
import qualified System.Metrics.Prometheus.Metric.Counter as PC
import qualified System.Metrics.Prometheus.Metric.Gauge as PG
import qualified System.Metrics.Prometheus.Metric.Histogram as PH
import System.Metrics.Prometheus.MetricId
import Prelude hiding (lookup)

-- | An 'EventBackend' that populates a 'Registry'.
--
-- All metrics are registered before the backend is returned.
prometheusEventBackend :: forall es s. (EventMetrics es) => Registry -> RenderSelectorPrometheus s es -> IO (EventBackend IO PrometheusReference s)
prometheusEventBackend :: forall es (s :: * -> *).
EventMetrics es =>
Registry
-> RenderSelectorPrometheus s es
-> IO (EventBackend IO PrometheusReference s)
prometheusEventBackend Registry
registry RenderSelectorPrometheus s es
render = do
  Map (Counter es) Counter
counters <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall k a. Eq k => [(k, a)] -> Map k a
fromAscList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [forall a. Bounded a => a
minBound @(Counter es) ..] forall a b. (a -> b) -> a -> b
$ \Counter es
cId -> do
    Counter
c <- Name -> Labels -> Registry -> IO Counter
registerCounter (forall a. EventMetric a => a -> Name
metricName Counter es
cId) (forall a. EventMetric a => a -> Labels
metricLabels Counter es
cId) Registry
registry
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (Counter es
cId, Counter
c)
  Map (Gauge es) Gauge
gauges <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall k a. Eq k => [(k, a)] -> Map k a
fromAscList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [forall a. Bounded a => a
minBound @(Gauge es) ..] forall a b. (a -> b) -> a -> b
$ \Gauge es
gId -> do
    Gauge
g <- Name -> Labels -> Registry -> IO Gauge
registerGauge (forall a. EventMetric a => a -> Name
metricName Gauge es
gId) (forall a. EventMetric a => a -> Labels
metricLabels Gauge es
gId) Registry
registry
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (Gauge es
gId, Gauge
g)
  Map (Histogram es) Histogram
histograms <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall k a. Eq k => [(k, a)] -> Map k a
fromAscList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [forall a. Bounded a => a
minBound @(Histogram es) ..] forall a b. (a -> b) -> a -> b
$ \Histogram es
hId -> do
    Histogram
h <- Name -> Labels -> [UpperBound] -> Registry -> IO Histogram
registerHistogram (forall a. EventMetric a => a -> Name
metricName Histogram es
hId) (forall a. EventMetric a => a -> Labels
metricLabels Histogram es
hId) (forall h. EventHistogram h => h -> [UpperBound]
metricBounds Histogram es
hId) Registry
registry
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (Histogram es
hId, Histogram
h)
  let Map k a
m !@ :: Map k a -> k -> IO a
!@ k
k = case forall k a. Ord k => k -> Map k a -> Maybe a
lookup k
k Map k a
m of
        Just a
a -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
        Maybe a
Nothing -> forall e a. Exception e => e -> IO a
throwIO NonExhaustiveMetricEnumeration
NonExhaustiveMetricEnumeration

      modifyCounter :: CounterModification -> Counter -> IO ()
modifyCounter (AddCounter Int
v) = Int -> Counter -> IO ()
PC.add Int
v
      modifyCounter CounterModification
IncCounter = Counter -> IO ()
PC.inc

      modifyGauge :: GaugeModification -> Gauge -> IO ()
modifyGauge (AddGauge UpperBound
v) = UpperBound -> Gauge -> IO ()
PG.add UpperBound
v
      modifyGauge (Sub UpperBound
v) = UpperBound -> Gauge -> IO ()
PG.sub UpperBound
v
      modifyGauge GaugeModification
IncGauge = Gauge -> IO ()
PG.inc
      modifyGauge GaugeModification
Dec = Gauge -> IO ()
PG.dec
      modifyGauge (Set UpperBound
v) = UpperBound -> Gauge -> IO ()
PG.set UpperBound
v

      modifyHistogram :: HistogramModification -> Histogram -> IO ()
modifyHistogram (Observe UpperBound
v) = UpperBound -> Histogram -> IO ()
PH.observe UpperBound
v

      performModification :: MetricModification es -> IO ()
performModification (ModifyCounter CounterModification
modC Counter es
cId) =
        Map (Counter es) Counter
counters forall {k} {a}. Ord k => Map k a -> k -> IO a
!@ Counter es
cId forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CounterModification -> Counter -> IO ()
modifyCounter CounterModification
modC
      performModification (ModifyGauge GaugeModification
modG Gauge es
gId) =
        Map (Gauge es) Gauge
gauges forall {k} {a}. Ord k => Map k a -> k -> IO a
!@ Gauge es
gId forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= GaugeModification -> Gauge -> IO ()
modifyGauge GaugeModification
modG
      performModification (ModifyHistogram HistogramModification
modH Histogram es
hId) =
        Map (Histogram es) Histogram
histograms forall {k} {a}. Ord k => Map k a -> k -> IO a
!@ Histogram es
hId forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HistogramModification -> Histogram -> IO ()
modifyHistogram HistogramModification
modH

      performModifications :: [MetricModification es] -> IO ()
performModifications = forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ MetricModification es -> IO ()
performModification
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    EventBackend
      { newEvent :: forall f.
NewEventArgs PrometheusReference s f
-> IO (Event IO PrometheusReference f)
newEvent = \(NewEventArgs {s f
[f]
[PrometheusReference]
Maybe PrometheusReference
newEventSelector :: forall r (s :: * -> *) f. NewEventArgs r s f -> s f
newEventParent :: forall r (s :: * -> *) f. NewEventArgs r s f -> Maybe r
newEventCauses :: forall r (s :: * -> *) f. NewEventArgs r s f -> [r]
newEventInitialFields :: forall r (s :: * -> *) f. NewEventArgs r s f -> [f]
newEventInitialFields :: [f]
newEventCauses :: [PrometheusReference]
newEventParent :: Maybe PrometheusReference
newEventSelector :: s f
..}) -> do
          let PrometheusRendered {f -> [MetricModification es]
[f] -> EventDuration -> [MetricModification es]
Maybe SomeException -> [f] -> [MetricModification es]
onFinalize :: forall f es.
PrometheusRendered f es
-> Maybe SomeException -> [f] -> [MetricModification es]
onField :: forall f es.
PrometheusRendered f es -> f -> [MetricModification es]
onStart :: forall f es.
PrometheusRendered f es
-> [f] -> EventDuration -> [MetricModification es]
onFinalize :: Maybe SomeException -> [f] -> [MetricModification es]
onField :: f -> [MetricModification es]
onStart :: [f] -> EventDuration -> [MetricModification es]
..} = RenderSelectorPrometheus s es
render s f
newEventSelector
          [MetricModification es] -> IO ()
performModifications forall a b. (a -> b) -> a -> b
$ [f] -> EventDuration -> [MetricModification es]
onStart [f]
newEventInitialFields EventDuration
Extended
          IORef [f]
fieldsRef <- forall a. a -> IO (IORef a)
newIORef []
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
            Event
              { reference :: PrometheusReference
reference = PrometheusReference
PrometheusReference,
                addField :: f -> IO ()
addField = \f
f -> do
                  [MetricModification es] -> IO ()
performModifications forall a b. (a -> b) -> a -> b
$ f -> [MetricModification es]
onField f
f
                  forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [f]
fieldsRef forall a b. (a -> b) -> a -> b
$ \[f]
fields ->
                    (f
f forall a. a -> [a] -> [a]
: [f]
fields, ()),
                finalize :: Maybe SomeException -> IO ()
finalize = \Maybe SomeException
e -> do
                  [f]
fields <- forall a. IORef a -> IO a
readIORef IORef [f]
fieldsRef
                  [MetricModification es] -> IO ()
performModifications forall a b. (a -> b) -> a -> b
$ Maybe SomeException -> [f] -> [MetricModification es]
onFinalize Maybe SomeException
e ([f]
newEventInitialFields forall a. [a] -> [a] -> [a]
++ (forall a. [a] -> [a]
reverse [f]
fields))
              },
        emitImmediateEvent :: forall f.
NewEventArgs PrometheusReference s f -> IO PrometheusReference
emitImmediateEvent = \(NewEventArgs {s f
[f]
[PrometheusReference]
Maybe PrometheusReference
newEventInitialFields :: [f]
newEventCauses :: [PrometheusReference]
newEventParent :: Maybe PrometheusReference
newEventSelector :: s f
newEventSelector :: forall r (s :: * -> *) f. NewEventArgs r s f -> s f
newEventParent :: forall r (s :: * -> *) f. NewEventArgs r s f -> Maybe r
newEventCauses :: forall r (s :: * -> *) f. NewEventArgs r s f -> [r]
newEventInitialFields :: forall r (s :: * -> *) f. NewEventArgs r s f -> [f]
..}) -> do
          let PrometheusRendered {f -> [MetricModification es]
[f] -> EventDuration -> [MetricModification es]
Maybe SomeException -> [f] -> [MetricModification es]
onFinalize :: Maybe SomeException -> [f] -> [MetricModification es]
onField :: f -> [MetricModification es]
onStart :: [f] -> EventDuration -> [MetricModification es]
onFinalize :: forall f es.
PrometheusRendered f es
-> Maybe SomeException -> [f] -> [MetricModification es]
onField :: forall f es.
PrometheusRendered f es -> f -> [MetricModification es]
onStart :: forall f es.
PrometheusRendered f es
-> [f] -> EventDuration -> [MetricModification es]
..} = RenderSelectorPrometheus s es
render s f
newEventSelector
          [MetricModification es] -> IO ()
performModifications forall a b. (a -> b) -> a -> b
$ [f] -> EventDuration -> [MetricModification es]
onStart [f]
newEventInitialFields EventDuration
Immediate
          forall (f :: * -> *) a. Applicative f => a -> f a
pure PrometheusReference
PrometheusReference
      }

-- | A specification of a collection of prometheus metrics.
--
-- Note that due to limitations in the underlying prometheus client library, summaries are not yet supported.
class (EventMetric (Counter es), EventMetric (Gauge es), EventHistogram (Histogram es)) => EventMetrics es where
  -- | The [counters](https://prometheus.io/docs/concepts/metric_types/#counter)
  type Counter es

  -- | The [gauges](https://prometheus.io/docs/concepts/metric_types/#gauge)
  type Gauge es

  -- | The [histograms](https://prometheus.io/docs/concepts/metric_types/#histogram)
  type Histogram es

-- | A specification of a single prometheus metric of any type
--
-- Must satisfy @∀ x : a, x \`elem\` [minBound .. maxBound]@
class (Ord a, Enum a, Bounded a) => EventMetric a where
  -- | The [name](https://prometheus.io/docs/practices/naming/#metric-names) of the metric
  metricName :: a -> Name

  -- | The [labels](https://prometheus.io/docs/practices/naming/#labels) of the metric
  metricLabels :: a -> Labels

-- | A specification of a prometheus [histogram](https://prometheus.io/docs/concepts/metric_types/#histogram)
class (EventMetric h) => EventHistogram h where
  -- | The upper bounds of the histogram buckets.
  metricBounds :: h -> [PH.UpperBound]

-- | Render all events selectable by @s@ to prometheus metrics according to 'EventMetrics' @es@
--
-- We may want to add functionality for easily combining 'RenderSelectorPrometheus's and 'EventMetrics'
-- from nested selector types, possibly with additional labels layered on top.
type RenderSelectorPrometheus s es = forall f. s f -> PrometheusRendered f es

-- | How to render a specific 'Event' according to 'EventMetrics' @es@
data PrometheusRendered f es = PrometheusRendered
  { -- | Modify metrics at event start
    --
    -- Passed the 'newEventInitialFields'.
    forall f es.
PrometheusRendered f es
-> [f] -> EventDuration -> [MetricModification es]
onStart :: !([f] -> EventDuration -> [MetricModification es]),
    -- | Modify metrics when a field is added
    --
    -- Only called for events added with 'addField'
    forall f es.
PrometheusRendered f es -> f -> [MetricModification es]
onField :: !(f -> [MetricModification es]),
    -- | Modify metrics when an event finishes.
    --
    -- Passed all event fields (both initial fields and those added
    -- during the event lifetime).
    --
    -- This is not called if the event is 'Immediate'.
    forall f es.
PrometheusRendered f es
-> Maybe SomeException -> [f] -> [MetricModification es]
onFinalize :: !(Maybe SomeException -> [f] -> [MetricModification es])
  }

-- | DSL for modifying metrics specified in 'EventMetrics' @es@
data MetricModification es
  = -- | Modify the specified counter
    ModifyCounter !CounterModification !(Counter es)
  | -- | Modify the specified gauge
    ModifyGauge !GaugeModification !(Gauge es)
  | -- | Modify the specified histogram
    ModifyHistogram !HistogramModification !(Histogram es)

-- | DSL for modifying a counter metric
data CounterModification
  = -- | Add a value to a counter
    AddCounter !Int
  | -- | Increment a counter
    IncCounter

-- | DSL for modifying a gauge metric
data GaugeModification
  = -- | Add a value to a gauge
    AddGauge !Double
  | -- | Subtract a value from a gauge
    Sub !Double
  | -- | Increment a gauge
    IncGauge
  | -- | Decrement a gauge
    Dec
  | -- | Set the value of a gauge
    Set !Double

-- | DSL for modifying a histogram metric
data HistogramModification
  = -- | Record an observation
    Observe !Double

-- | What duration event is this?
data EventDuration
  = -- | A immediately finalized event
    Immediate
  | -- | An event with an extended lifetime
    Extended

-- | Reference type for 'prometheusEventBackend'
--
-- Prometheus can't make use of references, so this carries no information.
data PrometheusReference = PrometheusReference

-- | Exception thrown if we encounter an element of an 'EventMetric' that
-- is not in @[minBound .. maxBound]@
data NonExhaustiveMetricEnumeration = NonExhaustiveMetricEnumeration deriving (Int -> NonExhaustiveMetricEnumeration -> ShowS
[NonExhaustiveMetricEnumeration] -> ShowS
NonExhaustiveMetricEnumeration -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NonExhaustiveMetricEnumeration] -> ShowS
$cshowList :: [NonExhaustiveMetricEnumeration] -> ShowS
show :: NonExhaustiveMetricEnumeration -> String
$cshow :: NonExhaustiveMetricEnumeration -> String
showsPrec :: Int -> NonExhaustiveMetricEnumeration -> ShowS
$cshowsPrec :: Int -> NonExhaustiveMetricEnumeration -> ShowS
Show)

instance Exception NonExhaustiveMetricEnumeration