ObservableGauge.hs

{-# OPTIONS_GHC -Wno-name-shadowing #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}

module Effectful.OpenTelemetry.Metrics.ObservableGauge (ObservableGauge, new) where

import Data.Maybe (maybeToList)
import Data.Scientific (Scientific)
import Data.Text (Text)
import Effectful
import Effectful.Dispatch.Static (unsafeEff_)
import Effectful.OpenTelemetry.Metrics.Effect (Metrics)
import Effectful.OpenTelemetry.Metrics.Effect qualified as Metrics
import Effectful.OpenTelemetry.Metrics.Gauge qualified as Gauge
import Effectful.OpenTelemetry.Metrics.Instrument (Instrument)
import Effectful.OpenTelemetry.Metrics.Instrument qualified as Instrument
import Effectful.OpenTelemetry.Metrics.Measurement (NumberDataPoint (..))
import Effectful.OpenTelemetry.Metrics.Metadata (Metadata (..))
import Effectful.OpenTelemetry.Timestamp (Timestamp)
import Effectful.OpenTelemetry.Timestamp qualified as Timestamp
import Prelude

-- | An asynchronous 'Instrument' which reports non-additive values when it is observed.
--
-- Example uses for 'ObservableGauge':
--
-- - the current room temperature
-- - the CPU fan speed
--
-- See <https://opentelemetry.io/docs/specs/otel/metrics/api/#asynchronous-gauge the OpenTelemetry spec>.
data ObservableGauge = ObservableGauge
    { name :: Text
    , startTime :: Timestamp
    , metadata :: Metadata
    , observe :: IO (Maybe Scientific)
    }

-- | Create a new 'ObservableGauge' with an observation callback.
new
    :: (Metrics :> es)
    => Text
    -> Metadata
    -> IO (Maybe Scientific)
    -> Eff es ObservableGauge
new name metadata observe =
    Metrics.register =<< unsafeEff_ do
        startTime <- Timestamp.now
        pure ObservableGauge{..}

instance Instrument ObservableGauge where
    name = name
    sample ObservableGauge{..} = do
        time <- Timestamp.now
        values <- maybeToList <$> observe
        pure
            [ (time, Gauge.measurement metadata name NumberDataPoint{attributes = metadata.attributes, ..})
            | value <- values
            ]