Gauge.hs

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

module Effectful.OpenTelemetry.Metrics.Gauge
    ( Gauge
    , new
    , set
    , setIO
    , measurement
    , Payload (..)
    )
where

import Control.Concurrent.STM (TMVar)
import Control.Concurrent.STM qualified as STM
import Data.Aeson.Types (ToJSON (..))
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.Instrument (Instrument)
import Effectful.OpenTelemetry.Metrics.Instrument qualified as Instrument
import Effectful.OpenTelemetry.Metrics.Measurement
    ( Measurement
    , Metric (..)
    , NumberDataPoint (..)
    )
import Effectful.OpenTelemetry.Metrics.Measurement qualified as Measurement
import Effectful.OpenTelemetry.Metrics.Metadata (Metadata (..))
import Effectful.OpenTelemetry.Timestamp (Timestamp)
import Effectful.OpenTelemetry.Timestamp qualified as Timestamp
import GHC.Generics (Generic)
import Proto3.Wire.Encode.Class qualified as Proto
import Prelude

-- | A synchronous 'Instrument' which records non-additive values when changes occur.
--
-- Example uses for 'Gauge':
--
-- - subscribe to change events for the background noise level
-- - subscribe to change events for the CPU fan speed
--
-- See <https://opentelemetry.io/docs/specs/otel/metrics/data-model/#gauge the OpenTelemetry spec>.
data Gauge = Gauge
    { name :: Text
    , startTime :: Timestamp
    , value :: TMVar (Timestamp, Scientific)
    , metadata :: Metadata
    }

-- | Create a new 'Gauge' and register it to be sampled and exported.
new :: (Metrics :> es) => Text -> Metadata -> Eff es Gauge
new name metadata =
    Metrics.register =<< unsafeEff_ do
        startTime <- Timestamp.now
        value <- STM.newEmptyTMVarIO
        pure Gauge{..}

-- | Set a 'Gauge' to the given value.
set :: (Metrics :> es) => Gauge -> Scientific -> Eff es ()
set = (unsafeEff_ .) . setIO

setIO :: Gauge -> Scientific -> IO ()
setIO gauge value = do
    time <- Timestamp.now
    STM.atomically . STM.writeTMVar gauge.value $ (time, value)

-- | A gauge 'Measurement' of a single observed data point.
measurement :: Metadata -> Text -> NumberDataPoint -> Measurement
measurement metadata name dataPoint =
    Measurement.create name metadata Payload{dataPoints = [dataPoint]}

instance Instrument Gauge where
    name = name
    sample Gauge{metadata = metadata@Metadata{..}, ..} = do
        measurements <- maybeToList <$> STM.atomically (STM.tryReadTMVar value)
        pure
            [ (time, measurement metadata name NumberDataPoint{..})
            | (time, value) <- measurements
            ]

newtype Payload = Payload {dataPoints :: [NumberDataPoint]}
    deriving stock (Generic, Show, Eq)
    deriving anyclass (ToJSON)

instance Proto.Encode Payload where
    encode Payload{..} = foldMap (Proto.encodeField 1) dataPoints

instance Metric Payload where
    metricJsonKey _ = "gauge"
    metricProtoFieldNumber _ = 5