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 Lens.Family2 ((^.))
import Network.GRPC.Client qualified as G
import Network.GRPC.Client.StreamType.IO qualified as G
import Network.GRPC.Common qualified as G
import Network.GRPC.Common.Protobuf (Protobuf)
import Network.GRPC.Common.Protobuf qualified as G
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 ::
  G.Connection ->
  ProcessT IO (Tick OMS.ExportMetricsServiceRequest) (Tick ExportMetricsResult)
exportResourceMetrics conn = 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 =
    doGrpc `catch` handleSomeException
   where
    !exportedDataPoints = countDataPointsInExportMetricsServiceRequest exportMetricsServiceRequest

    doGrpc :: IO ExportMetricsResult
    doGrpc = do
      G.nonStreaming conn (G.rpc @(Protobuf OMS.MetricsService "export")) (G.Proto exportMetricsServiceRequest) >>= \case
        G.Proto resp
          | resp ^. OMS.partialSuccess . OMS.rejectedDataPoints == 0 -> do
              pure $ ExportMetricsSuccess exportedDataPoints
          | otherwise -> do
              let !rejectedDataPoints = resp ^. OMS.partialSuccess . OMS.rejectedDataPoints
              let !rejectedMetricsError = RejectedMetricsError{errorMessage = resp ^. OMS.partialSuccess . OMS.errorMessage, ..}
              pure $ ExportMetricsError exportedDataPoints rejectedDataPoints (SomeException rejectedMetricsError)

    -- handleGrpcError :: G.GrpcError -> IO ExportMetricsResult
    -- handleGrpcError grpcError = pure $ ExportMetricsError 0 exportedDataPoints (SomeException grpcError)

    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

--------------------------------------------------------------------------------
-- 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)