Metrics.hs

{-# OPTIONS_GHC -Wno-orphans #-}

module GHC.Eventlog.Live.Otelcol.Exporter.Metrics (
  -- * Metrics
  ExportMetricsResult (..),
  RejectedMetricsError (..),
  exportResourceMetrics,
) where

import Control.Exception (Exception (..), SomeException (..), catch)
import Control.Monad (unless)
import Control.Monad.IO.Class (MonadIO (..))
import Data.Int (Int64)
import Data.Machine (ProcessT, await, construct, yield)
import Data.Semigroup (Sum (..))
import Data.Text (Text)
import Data.Vector qualified as V
import GHC.Eventlog.Live.Machine.Core (Tick (..))
import GHC.Eventlog.Live.Otelcol.Exporter.Core (CanExportViaHttpProtobuf (..), OtlpExporter (..), export)
import Lens.Family2 ((^.))
import Network.GRPC.Common qualified as G
import Network.GRPC.Common.Protobuf (Protobuf)
import Proto.Opentelemetry.Proto.Collector.Metrics.V1.MetricsService qualified as OMS
import Proto.Opentelemetry.Proto.Collector.Metrics.V1.MetricsService_Fields qualified as OMS
import Proto.Opentelemetry.Proto.Metrics.V1.Metrics qualified as OM
import Proto.Opentelemetry.Proto.Metrics.V1.Metrics_Fields qualified as OM
import Text.Printf (printf)

--------------------------------------------------------------------------------
-- OpenTelemetry gRPC Exporters
--------------------------------------------------------------------------------

--------------------------------------------------------------------------------
-- OpenTelemetry Exporter Result for Metrics

data ExportMetricsResult
  = ExportMetricsResult
  { exportedDataPoints :: !Int64
  , rejectedDataPoints :: !Int64
  , maybeSomeException :: Maybe SomeException
  }
  deriving (Show)

pattern ExportMetricsSuccess :: Int64 -> ExportMetricsResult
pattern ExportMetricsSuccess exportedDataPoints =
  ExportMetricsResult exportedDataPoints 0 Nothing

pattern ExportMetricsError :: Int64 -> Int64 -> SomeException -> ExportMetricsResult
pattern ExportMetricsError exportedDataPoints rejectedDataPoints someException =
  ExportMetricsResult exportedDataPoints rejectedDataPoints (Just someException)

data RejectedMetricsError
  = RejectedMetricsError
  { rejectedDataPoints :: !Int64
  , errorMessage :: !Text
  }
  deriving (Show)

instance Exception RejectedMetricsError where
  displayException :: RejectedMetricsError -> String
  displayException RejectedMetricsError{..} =
    printf "Error: OpenTelemetry Collector rejected %d data points with message: %s" rejectedDataPoints errorMessage

--------------------------------------------------------------------------------
-- OpenTelemetry gRPC Exporter for Metrics

exportResourceMetrics ::
  OtlpExporter ->
  ProcessT IO (Tick OMS.ExportMetricsServiceRequest) (Tick ExportMetricsResult)
exportResourceMetrics exporter = construct $ go False
 where
  go exportedResourceMetrics =
    await >>= \case
      Tick -> do
        unless exportedResourceMetrics $
          yield (Item $ ExportMetricsSuccess 0)
        yield Tick
        go False
      Item exportMetricsServiceRequest -> do
        exportMetricsResult <- liftIO (sendResourceMetrics exportMetricsServiceRequest)
        yield (Item exportMetricsResult)
        go True

  sendResourceMetrics :: OMS.ExportMetricsServiceRequest -> IO ExportMetricsResult
  sendResourceMetrics exportMetricsServiceRequest =
    doExport `catch` handleSomeException
   where
    !exportedDataPoints = countDataPointsInExportMetricsServiceRequest exportMetricsServiceRequest

    doExport :: IO ExportMetricsResult
    doExport = do
      resp <- export @OMS.MetricsService @"export" exporter exportMetricsServiceRequest
      if resp ^. OMS.partialSuccess . OMS.rejectedDataPoints == 0
        then
          pure $ ExportMetricsSuccess exportedDataPoints
        else do
          let !rejectedDataPoints = resp ^. OMS.partialSuccess . OMS.rejectedDataPoints
          let !rejectedMetricsError = RejectedMetricsError{errorMessage = resp ^. OMS.partialSuccess . OMS.errorMessage, ..}
          pure $ ExportMetricsError exportedDataPoints rejectedDataPoints (SomeException rejectedMetricsError)

    handleSomeException :: SomeException -> IO ExportMetricsResult
    handleSomeException someException = pure $ ExportMetricsError 0 exportedDataPoints someException

type instance G.RequestMetadata (Protobuf OMS.MetricsService meth) = G.NoMetadata
type instance G.ResponseInitialMetadata (Protobuf OMS.MetricsService meth) = G.NoMetadata
type instance G.ResponseTrailingMetadata (Protobuf OMS.MetricsService meth) = G.NoMetadata

instance CanExportViaHttpProtobuf OMS.MetricsService "export" where
  apiPath :: String
  apiPath = "/v1/metrics"

--------------------------------------------------------------------------------
-- Internal Helpers
--------------------------------------------------------------------------------

{- |
Internal helper.
Count the number of `OM.NumberDataPoint` values in an `OMS.ExportMetricsServiceRequest`.
-}
{-# SPECIALIZE countDataPointsInExportMetricsServiceRequest :: OMS.ExportMetricsServiceRequest -> Int64 #-}
{-# SPECIALIZE countDataPointsInExportMetricsServiceRequest :: OMS.ExportMetricsServiceRequest -> Word #-}
countDataPointsInExportMetricsServiceRequest :: (Integral i) => OMS.ExportMetricsServiceRequest -> i
countDataPointsInExportMetricsServiceRequest exportMetricsServiceRequest =
  getSum $ foldMap (Sum . countDataPointsInResourceMetrics) (exportMetricsServiceRequest ^. OMS.vec'resourceMetrics)

{- |
Internal helper.
Count the number of `OM.NumberDataPoint` values in an `OM.ResourceMetrics`.
-}
{-# SPECIALIZE countDataPointsInResourceMetrics :: OM.ResourceMetrics -> Int64 #-}
{-# SPECIALIZE countDataPointsInResourceMetrics :: OM.ResourceMetrics -> Word #-}
countDataPointsInResourceMetrics :: (Integral i) => OM.ResourceMetrics -> i
countDataPointsInResourceMetrics resourceMetrics =
  getSum $ foldMap (Sum . countDataPointsInScopeMetrics) (resourceMetrics ^. OM.vec'scopeMetrics)

{- |
Internal helper.
Count the number of `OM.NumberDataPoint` values in an `OM.ScopeMetrics`.
-}
{-# SPECIALIZE countDataPointsInScopeMetrics :: OM.ScopeMetrics -> Int64 #-}
{-# SPECIALIZE countDataPointsInScopeMetrics :: OM.ScopeMetrics -> Word #-}
countDataPointsInScopeMetrics :: (Integral i) => OM.ScopeMetrics -> i
countDataPointsInScopeMetrics scopeMetrics =
  getSum $ foldMap (Sum . countDataPointsInMetric) (scopeMetrics ^. OM.vec'metrics)

{- |
Internal helper.
Count the number of `OM.NumberDataPoint` values in an `OM.Metric`.
-}
{-# SPECIALIZE countDataPointsInMetric :: OM.Metric -> Int64 #-}
{-# SPECIALIZE countDataPointsInMetric :: OM.Metric -> Word #-}
countDataPointsInMetric :: (Integral i) => OM.Metric -> i
countDataPointsInMetric metric =
  fromIntegral $
    case metric ^. OM.maybe'data' of
      Nothing -> 0
      Just (OM.Metric'Gauge gauge) ->
        V.length (gauge ^. OM.vec'dataPoints)
      Just (OM.Metric'Sum sum_) ->
        V.length (sum_ ^. OM.vec'dataPoints)
      Just (OM.Metric'Histogram histogram) ->
        V.length (histogram ^. OM.vec'dataPoints)
      Just (OM.Metric'ExponentialHistogram exponentialHistogram) ->
        V.length (exponentialHistogram ^. OM.vec'dataPoints)
      Just (OM.Metric'Summary summary) ->
        V.length (summary ^. OM.vec'dataPoints)