MetricsSpec.hs

{-# OPTIONS_GHC -Wno-type-defaults #-}

module Effectful.OpenTelemetry.MetricsSpec (spec) where

import Arbitrary
import Control.Monad (forM_)
import Data.Either (isLeft)
import Data.Foldable (for_)
import Data.IORef (atomicModifyIORef', modifyIORef', newIORef, readIORef, writeIORef)
import Data.List qualified as List
import Data.List.Extra (nubOrd)
import Data.Maybe (isJust, mapMaybe)
import Data.Text (Text)
import Effectful
import Effectful.Concurrent (runConcurrent, threadDelay)
import Effectful.Concurrent.Async (replicateConcurrently_)
import Effectful.Exception (SomeException, throwIO, try)
import Effectful.HUnit (HUnit, assertFailure)
import Effectful.Hspec
import Effectful.OpenTelemetry.Exporter qualified as Exporter
import Effectful.OpenTelemetry.Metrics
import Effectful.OpenTelemetry.Metrics.Counter qualified as Counter
import Effectful.OpenTelemetry.Metrics.Gauge qualified as Gauge
import Effectful.OpenTelemetry.Metrics.Histogram qualified as Histogram
import Effectful.OpenTelemetry.Metrics.Metadata
import Effectful.OpenTelemetry.Metrics.ObservableCounter qualified as ObservableCounter
import Effectful.OpenTelemetry.Metrics.ObservableGauge qualified as ObservableGauge
import Effectful.OpenTelemetry.Metrics.ObservableUpDownCounter qualified as ObservableUpDownCounter
import Effectful.OpenTelemetry.Metrics.RTS qualified as Metrics.RTS
import Effectful.OpenTelemetry.Metrics.Sum qualified as Sum
import Effectful.OpenTelemetry.Metrics.UpDownCounter qualified as UpDownCounter
import Effectful.OpenTelemetry.Timestamp (Timestamp (..))
import Effectful.QuickCheck (NonNegative (..), Small (..))
import Util
import Prelude

getLastMeasurement :: (HUnit :> es) => [Measurement] -> Eff es Measurement
getLastMeasurement [] = assertFailure "Expected at least 1 measurement"
getLastMeasurement ms = pure $ last ms

named :: Text -> [Measurement] -> Maybe Measurement
named n = List.find ((n ==) . (.name))

spec :: (IOE :> es, HUnit :> es, Hspec :> es) => Eff es ()
spec = runConcurrent . parallel $ do
    describe "Counter" do
        it "has initial value zero" do
            m <-
                only . snd =<< runInMemoryMetrics do
                    _ <- Counter.new "requests" mempty
                    pure ()
            m.name `shouldBe` "requests"
            numberValue m `shouldBe` Just 0

        prop "increments monotonically" \(NonNegative (Small a)) (NonNegative (Small b)) -> do
            m <-
                only . snd =<< runInMemoryMetrics do
                    c <- Counter.new "ops" mempty
                    Counter.add c a
                    Counter.add c b
            numberValue m `shouldBe` Just (a + b)
            Sum.Payload{isMonotonic} <- maybe (assertFailure "not a Sum") pure $ toMetric m
            isMonotonic `shouldBe` True

        prop "carries its metadata" \metadata -> do
            m <-
                only . snd =<< runInMemoryMetrics do
                    c <- Counter.new "documented" metadata
                    Counter.add c 1
            m.description `shouldBe` metadata.description
            m.unit `shouldBe` metadata.unit
            dp <- maybe (assertFailure "no number data point") pure $ numberDataPoint m
            dp.attributes `shouldBe` metadata.attributes

    describe "UpDownCounter" do
        it "has initial value zero" do
            m <-
                only . snd =<< runInMemoryMetrics do
                    _ <- UpDownCounter.new "requests" mempty
                    pure ()
            m.name `shouldBe` "requests"
            numberValue m `shouldBe` Just 0

        prop "increments non-monotonically" \(Small a) (Small b) -> do
            m <-
                only . snd =<< runInMemoryMetrics do
                    c <- UpDownCounter.new "ops" mempty
                    UpDownCounter.add c a
                    UpDownCounter.add c b
            numberValue m `shouldBe` Just (a + b)
            Sum.Payload{isMonotonic} <- maybe (assertFailure "not a Sum") pure $ toMetric m
            isMonotonic `shouldBe` False

        prop "carries its metadata" \metadata -> do
            m <-
                only . snd =<< runInMemoryMetrics do
                    c <- UpDownCounter.new "documented" metadata
                    UpDownCounter.add c 1
            m.description `shouldBe` metadata.description
            m.unit `shouldBe` metadata.unit
            dp <- maybe (assertFailure "no number data point") pure $ numberDataPoint m
            dp.attributes `shouldBe` metadata.attributes

    describe "data point attributes" do
        prop "carries its attributes" \attrs -> do
            m <-
                only . snd =<< runInMemoryMetrics do
                    c <-
                        Counter.new
                            "labelled"
                            Metadata{attributes = attrs, description = Nothing, unit = Nothing}
                    Counter.add c 1
            dp <- maybe (assertFailure "no number data point") pure $ numberDataPoint m
            dp.attributes `shouldBe` attrs

    describe "Gauge" do
        it "never set, never exported" do
            (_, measurements) <- runInMemoryMetrics do
                _ <- Gauge.new "temperature" mempty
                pure ()
            measurements `shouldSatisfy` null

        prop "last value wins" \(NonNegative a) (NonNegative b) (NonNegative c) -> do
            m <-
                getLastMeasurement . snd =<< runInMemoryMetrics do
                    g <- Gauge.new "memory" mempty
                    Gauge.set g a
                    Gauge.set g b
                    Gauge.set g c
            numberValue m `shouldBe` Just c

    describe "Multiple instruments" do
        prop "are independent" \(NonNegative (Small a)) (NonNegative v) -> do
            (_, measurements) <- runInMemoryMetrics do
                c <- UpDownCounter.new "req_count" mempty
                g <- Gauge.new "req_latency" mempty
                UpDownCounter.add c a
                Gauge.set g v
            length measurements `shouldBe` 2
            (numberValue =<< named "req_count" measurements) `shouldBe` Just a
            (numberValue =<< named "req_latency" measurements) `shouldBe` Just v

    describe "Concurrency" do
        prop "up-down counter increments are atomic" \ConcurrentObservation{repeats} (NonNegative (Small value)) -> do
            m <-
                only . snd =<< (runConcurrent . runInMemoryMetrics) do
                    c <- UpDownCounter.new "concurrent" mempty
                    replicateConcurrently_ repeats $ UpDownCounter.add c value
            numberValue m `shouldBe` Just (fromIntegral repeats * value)

        it "gauge sets converge" do
            m <-
                only . snd =<< (runConcurrent . runInMemoryMetrics) do
                    g <- Gauge.new "contended" mempty
                    replicateConcurrently_ 50 $ Gauge.set g 42
            numberValue m `shouldBe` Just 42

        it "instrument creation is safe" do
            m <-
                only . snd =<< (runConcurrent . runInMemoryMetrics) do
                    replicateConcurrently_ 20 do
                        c <- UpDownCounter.new "shared" mempty
                        UpDownCounter.add c 1
                    pure ()
            m.name `shouldBe` "shared"

    describe "Histogram" do
        it "starts empty" do
            m <-
                only . snd =<< runInMemoryMetrics do
                    _ <- Histogram.new "latency_ms" mempty
                    pure ()
            m.name `shouldBe` "latency_ms"
            dp <- maybe (assertFailure "no histogram data point") pure $ histogramDataPoint m
            dp.count `shouldBe` 0
            dp.sum `shouldBe` Nothing

        prop "bounds and stats match" \(HistogramBounds bounds) (HistogramObservations samples) -> do
            m <-
                only . snd =<< runInMemoryMetrics do
                    h <- Histogram.newWithBounds "weights" bounds mempty
                    mapM_ (Histogram.record h) samples
            dp <- maybe (assertFailure "no histogram data point") pure $ histogramDataPoint m
            dp.explicitBounds `shouldBe` List.sort bounds
            dp.count `shouldBe` fromIntegral (length samples)
            case dp.sum of
                Just s -> abs (s - Prelude.sum samples) `shouldSatisfy` (< 1e-9)
                Nothing -> expectationFailure "no sum reported"
            dp.minValue `shouldBe` Just (minimum samples)
            dp.maxValue `shouldBe` Just (maximum samples)

        prop "carries its attributes" \attributes -> do
            m <-
                only . snd =<< runInMemoryMetrics do
                    h <- Histogram.new "attributed" Metadata{attributes, description = Nothing, unit = Nothing}
                    mapM_ (Histogram.record h) [1, 2, 3]
            dp <- maybe (assertFailure "no histogram data point") pure $ histogramDataPoint m
            dp.attributes `shouldBe` attributes

        prop "gauges and histograms carry metadata too" \metadataG metadataH (NonNegative v) -> do
            (_, measurements) <- runInMemoryMetrics do
                g <- Gauge.new "temperature" metadataG
                Gauge.set g v
                _ <- Histogram.new "latency" metadataH
                pure ()
            length measurements `shouldBe` 2
            tempMeasurement <-
                maybe (assertFailure "temperature not found") pure $ named "temperature" measurements
            histMeasurement <- maybe (assertFailure "latency not found") pure $ named "latency" measurements
            tempMeasurement.description `shouldBe` metadataG.description
            tempMeasurement.unit `shouldBe` metadataG.unit
            histMeasurement.description `shouldBe` metadataH.description
            histMeasurement.unit `shouldBe` metadataH.unit

        it "start precedes observation" do
            (_, measurements) <- runInMemoryMetrics do
                c <- Counter.new "started_total" mempty
                Counter.add c 1
                g <- Gauge.new "started_gauge" mempty
                Gauge.set g 1
                h <- Histogram.new "started_hist" mempty
                Histogram.record h 1
            let numberWindow m = (\dp -> (dp.startTime, dp.time)) <$> numberDataPoint m
                histogramWindow m = (\dp -> (dp.startTime, dp.time)) <$> histogramDataPoint m
                windows :: [(Timestamp, Timestamp)]
                windows = mapMaybe numberWindow measurements <> mapMaybe histogramWindow measurements
            length windows `shouldBe` length measurements
            windows `shouldSatisfy` all \(start, time) -> start.nanos > 0 && start <= time

        prop "bucket placement" \BucketedObservations{..} -> do
            m <-
                only . snd =<< runInMemoryMetrics do
                    h <- Histogram.newWithBounds "buckets" bounds mempty
                    mapM_ (Histogram.record h) $ mconcat observations
            dp <- maybe (assertFailure "no histogram data point") pure $ histogramDataPoint m
            dp.bucketCounts `shouldBe` (fromIntegral . length <$> observations)

        prop "concurrent observations are atomic" \ConcurrentObservation{..} -> do
            m <-
                only . snd =<< (runConcurrent . runInMemoryMetrics) do
                    h <- Histogram.new "concurrent_obs" mempty
                    replicateConcurrently_ repeats $ Histogram.record h value
            dp <- maybe (assertFailure "no histogram data point") pure $ histogramDataPoint m
            dp.count `shouldBe` fromIntegral repeats

    describe "asynchronous instruments" do
        prop "reports under its own name" \(NonNegative v) -> do
            m <-
                only . snd =<< runInMemoryMetrics do
                    _ <- ObservableGauge.new "obs.ratio" mempty . pure $ Just v
                    pure ()
            numberValue m `shouldBe` Just v

        prop "each kind reports correctly" \(NonNegative (Small a)) (NonNegative (Small b)) (NonNegative c) -> do
            (_, measurements) <- runInMemoryMetrics do
                _ <- ObservableCounter.new "obs.total" mempty $ pure a
                _ <- ObservableUpDownCounter.new "obs.size" mempty $ pure b
                _ <- ObservableGauge.new "obs.ratio" mempty . pure $ Just c
                pure ()
            (numberValue =<< named "obs.total" measurements) `shouldBe` Just a
            (numberValue =<< named "obs.size" measurements) `shouldBe` Just b
            (numberValue =<< named "obs.ratio" measurements) `shouldBe` Just c
            Sum.Payload{isMonotonic = totalMonotonic} <-
                maybe (assertFailure "obs.total not found") pure $ toMetric =<< named "obs.total" measurements
            Sum.Payload{isMonotonic = sizeMonotonic} <-
                maybe (assertFailure "obs.size not found") pure $ toMetric =<< named "obs.size" measurements
            totalMonotonic `shouldBe` True
            sizeMonotonic `shouldBe` False

        it "observes lazily" do
            ref <- liftIO $ newIORef 1
            m <-
                only . snd =<< runInMemoryMetrics do
                    _ <- ObservableGauge.new "obs.late" mempty $ Just <$> readIORef ref
                    liftIO $ writeIORef ref 42
            numberValue m `shouldBe` Just 42

        it "one callback per export" do
            ref <- liftIO $ newIORef (0 :: Int)
            _ <- runInMemoryMetrics do
                _ <- ObservableGauge.new "obs.counted" mempty do
                    calls <- atomicModifyIORef' ref \n -> (n + 1, n + 1)
                    pure . Just $ fromIntegral calls
                pure ()
            calls <- liftIO $ readIORef ref
            calls `shouldBe` 1

        it "nothing observed, nothing reported" do
            (_, measurements) <- runInMemoryMetrics do
                _ <- ObservableGauge.new "obs.empty" mempty $ pure Nothing
                pure ()
            measurements `shouldSatisfy` null

    describe "runMetricsWith" do
        it "samples once, even if the action raises" do
            sunk <- liftIO $ newIORef []
            (result :: Either SomeException ()) <-
                try @SomeException . runMetricsWith Nothing (Exporter.fromIO \m -> modifyIORef' sunk (<> [m])) $ do
                    c <- Counter.new "with.ops" mempty
                    Counter.add c 5
                    liftIO (length <$> readIORef sunk) `shouldReturn` 0
                    throwIO $ userError "boom"
            result `shouldSatisfy` isLeft
            m <- only =<< liftIO (readIORef sunk)
            numberValue m `shouldBe` Just 5

        it "samples repeatedly when given an interval" do
            sunk <- liftIO $ newIORef []
            runMetricsWith (Just 20) (Exporter.fromIO \m -> modifyIORef' sunk (<> [m])) do
                c <- Counter.new "with.periodic" mempty
                forM_ [1 .. 5 :: Int] . const $ Counter.add c 1 >> threadDelay 50_000
            measurements <- liftIO (readIORef sunk)
            mapMaybe numberValue measurements `shouldBe` [1, 2, 3, 4, 5]

    describe "RTS metrics" do
        it "reports readings" do
            (_, measurements) <- runInMemoryMetrics Metrics.RTS.register
            measurements `shouldSatisfy` any (("rts.allocated_bytes" ==) . (.name))
            measurements `shouldSatisfy` any (("rts.gc.allocated_bytes" ==) . (.name))

        it "observed at the same time" do
            (_, measurements) <- runInMemoryMetrics Metrics.RTS.register
            let times = mapMaybe (fmap (.time) . numberDataPoint) measurements
            times `shouldSatisfy` (1 ==) . length . nubOrd

        it "readings have metadata" do
            (_, measurements) <- runInMemoryMetrics Metrics.RTS.register
            for_ measurements \m -> do
                m.name `shouldNotBe` ""
                m.description `shouldSatisfy` isJust
                m.unit `shouldSatisfy` isJust