Measurement.hs

{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}

module Effectful.OpenTelemetry.Metrics.Measurement where

import Data.Aeson.KeyMap qualified as KeyMap
import Data.Aeson.Types (Key, ToJSON (..), Value (..), object, (.=))
import Data.Foldable qualified as Foldable
import Data.Functor ((<&>))
import Data.Scientific (Scientific)
import Data.Scientific qualified as Scientific
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Typeable (Typeable, cast)
import Data.Word (Word64)
import Effectful.OpenTelemetry.Metrics.Metadata (Metadata (..))
import Effectful.OpenTelemetry.Protocol.Attributes (Attributes)
import Effectful.OpenTelemetry.Protocol.Export qualified as Export
import Effectful.OpenTelemetry.Protocol.Resource qualified as Resource
import Effectful.OpenTelemetry.Protocol.Scope qualified as Scope
import Effectful.OpenTelemetry.Timestamp (Timestamp)
import GHC.Generics (Generic)
import Network.GRPC.HTTP2.Proto3Wire (RPC (..))
import Prettyprinter (Pretty (..))
import Prettyprinter.Extra (PrettyAnn (..))
import Prettyprinter.Extra qualified as Pretty
import Proto3.Wire.Encode.Class qualified as Proto
import Prelude

-- | Represents a data point reported via the OpenTelemetry metrics API.
--
-- See <https://opentelemetry.io/docs/specs/otel/metrics/api/#measurement the OpenTelemetry spec>.
data Measurement where
    Measurement
        :: (Metric d)
        => { name :: Text
           , description :: Maybe Text
           , unit :: Maybe Text
           , metric :: d
           }
        -> Measurement

instance Show Measurement where
    show Measurement{..} =
        "Measurement{name="
            <> show name
            <> ",description="
            <> show description
            <> ",unit="
            <> show unit
            <> ",metric="
            <> show (toJSON metric)
            <> "}"

instance ToJSON Measurement where
    toJSON Measurement{..} =
        object
            [ "name" .= name
            , "description" .= description
            , "unit" .= unit
            , metricJsonKey metric .= metric
            ]

-- https://github.com/open-telemetry/opentelemetry-proto/blob/main/opentelemetry/proto/metrics/v1/metrics.proto
instance Proto.Encode Measurement where
    encode Measurement{..} =
        mconcat
            [ Proto.encodeField 1 name
            , foldMap (Proto.encodeField 2) description
            , foldMap (Proto.encodeField 3) unit
            , Proto.encodeField (metricProtoFieldNumber metric) metric
            ]

instance PrettyAnn ann Measurement where
    prettyAnn Measurement{..} =
        Pretty.unwords . filter (not . Pretty.null) $
            [ pretty name <> ":"
            , case toJSON metric of
                Object (KeyMap.lookup "dataPoints" -> Just (Array dataPoints)) ->
                    Pretty.intercalate ", " $
                        Foldable.toList dataPoints <&> \case
                            Object dataPoint ->
                                prettyAnn . Object $
                                    KeyMap.filterWithKey
                                        (\key _ -> key `elem` ["asDouble", "asInt", "count", "max", "min", "sum"])
                                        dataPoint
                            val -> prettyAnn val
                val -> prettyAnn val
            , maybe "" pretty unit
            ]

instance Export.Request Measurement where
    exportHttpPathComponents = ["v1", "metrics"]
    exportGrpcRPC =
        RPC
            { pkg = "opentelemetry.proto.collector.metrics.v1"
            , srv = "MetricsService"
            , meth = "Export"
            }
    exportJson = object . pure . ("resourceMetrics" .=) . fmap resourceMetrics
      where
        resourceMetrics :: Resource.Items Measurement -> Value
        resourceMetrics Resource.Items{..} =
            object
                [ "resource" .= resource
                , "scopeMetrics" .= fmap scopeMetrics scopeItems
                ]
        scopeMetrics :: Scope.Items Measurement -> Value
        scopeMetrics Scope.Items{..} =
            object
                [ "scope" .= scope
                , "metrics" .= items
                ]

    transportSignalEnvName = "METRICS"
    exportSignalEnvName = "METRIC"
    batchEnvPrefix = Nothing

    defaultConfig =
        Export.Config
            { batch = Nothing
            , exportTimeoutMs = 30_000
            }

-- | Build a 'Measurement' for a metric of the given name, taking its
-- description and unit from the instrument's 'Metadata'.
create :: (Metric d) => Text -> Metadata -> d -> Measurement
create name Metadata{..} metric = Measurement{..}

-- | How to embed a metric in an OTLP payload.
class (Typeable d, ToJSON d, Proto.Encode d) => Metric d where
    -- | JSON field name under which this metric is nested.
    metricJsonKey :: d -> Key

    -- | Proto field number under which this metric is nested.
    metricProtoFieldNumber :: d -> Proto.FieldNumber

-- | Recover a 'Measurement''s underlying metric, if it is of the given type.
toMetric :: (Metric d) => Measurement -> Maybe d
toMetric Measurement{metric} = cast metric

-- | A single data point in a timeseries that describes the time-varying
-- scalar value of a metric.
data NumberDataPoint = NumberDataPoint
    { attributes :: Attributes
    , startTime :: Timestamp
    , time :: Timestamp
    , value :: Scientific
    }
    deriving stock (Generic, Show, Eq)

instance ToJSON NumberDataPoint where
    toJSON dp =
        object $
            [ "attributes" .= dp.attributes
            , "startTimeUnixNano" .= dp.startTime
            , "timeUnixNano" .= dp.time
            ]
                <> case Scientific.floatingOrInteger @Double @Integer dp.value of
                    Left _ -> ["asDouble" .= dp.value]
                    Right i -> ["asInt" .= Text.show i]

instance Proto.Encode NumberDataPoint where
    encode dp =
        mconcat
            [ Proto.encodeField 7 dp.attributes
            , Proto.encodeField 2 dp.startTime
            , Proto.encodeField 3 dp.time
            , either (Proto.double 4) (Proto.sfixed64 6) $
                Scientific.floatingOrInteger dp.value
            ]

-- | A single data point in a timeseries that describes the time-varying values of a histogram.
data HistogramDataPoint = HistogramDataPoint
    { attributes :: Attributes
    , startTime :: Timestamp
    , time :: Timestamp
    , count :: Word64
    , sum :: Maybe Scientific
    , bucketCounts :: [Word64]
    , explicitBounds :: [Scientific]
    , minValue :: Maybe Scientific
    , maxValue :: Maybe Scientific
    }
    deriving stock (Generic, Show, Eq)

instance ToJSON HistogramDataPoint where
    toJSON dp =
        object $
            [ "attributes" .= dp.attributes
            , "startTimeUnixNano" .= dp.startTime
            , "timeUnixNano" .= dp.time
            , "count" .= Text.show dp.count
            , "bucketCounts" .= (Text.show <$> dp.bucketCounts)
            , "explicitBounds" .= dp.explicitBounds
            ]
                <> ["sum" .= v | Just v <- [dp.sum]]
                <> ["min" .= v | Just v <- [dp.minValue]]
                <> ["max" .= v | Just v <- [dp.maxValue]]

instance Proto.Encode HistogramDataPoint where
    encode dp =
        mconcat
            [ Proto.encodeField 2 dp.startTime
            , Proto.encodeField 3 dp.time
            , Proto.fixed64 4 dp.count
            , foldMap (Proto.double 5 . Scientific.toRealFloat) dp.sum
            , foldMap (Proto.fixed64 6) dp.bucketCounts
            , foldMap (Proto.double 7 . Scientific.toRealFloat) dp.explicitBounds
            , Proto.encodeField 9 dp.attributes
            , foldMap (Proto.double 11 . Scientific.toRealFloat) dp.minValue
            , foldMap (Proto.double 12 . Scientific.toRealFloat) dp.maxValue
            ]

-- | Defines how a metric aggregator reports aggregated values.
--
-- See <https://opentelemetry.io/docs/specs/otel/metrics/data-model/#temporality the OpenTelemetry spec>.
data AggregationTemporality
    = -- | Aggregator reports changes since /last report time/.
      -- This means that successive data points /advance/ the starting timestamp.
      TemporalityDelta
    | -- | Aggregator reports changes since /a fixed start time/.
      -- This means that successive data points /repeat/ the starting timestamp.
      TemporalityCumulative
    deriving stock (Generic, Show, Eq, Bounded)

instance Enum AggregationTemporality where
    toEnum 1 = TemporalityDelta
    toEnum 2 = TemporalityCumulative
    toEnum _ = error "Enum.AggregationTemporality.toEnum: bad argument"

    fromEnum TemporalityDelta = 1
    fromEnum TemporalityCumulative = 2

instance {-# OVERLAPPING #-} Proto.EncodeField AggregationTemporality where
    encodeField n = Proto.int32 n . fromIntegral . fromEnum