PropagatorSpec.hs

module Effectful.OpenTelemetry.Tracing.PropagatorSpec (spec) where

import Arbitrary ()
import Data.ByteString (ByteString)
import Data.ByteString qualified as ByteString
import Effectful
import Effectful.Hspec
import Effectful.OpenTelemetry.Tracing.Propagator qualified as Propagator
import Effectful.OpenTelemetry.Tracing.Span.Context (Context)
import Effectful.OpenTelemetry.Tracing.Span.Context qualified as Span.Context
import Effectful.OpenTelemetry.Tracing.Trace.Flags qualified as Trace.Flags
import Prelude

spec :: (IOE :> es, Hspec :> es) => Eff es ()
spec = do
    describe "w3cTraceContext" do
        prop "round-trips a context through headers, marking it remote" \(ctx :: Context) -> do
            headers <- Propagator.w3cTraceContext.inject (Just ctx) mempty
            Propagator.w3cTraceContext.extract headers Nothing >>= \case
                Nothing -> expectationFailure "no context extracted"
                Just extracted -> do
                    extracted.traceId `shouldBe` ctx.traceId
                    extracted.spanId `shouldBe` ctx.spanId
                    extracted.traceState `shouldBe` ctx.traceState
                    Trace.Flags.sampled extracted.traceFlags `shouldBe` Trace.Flags.sampled ctx.traceFlags
                    Trace.Flags.remote extracted.traceFlags `shouldBe` Trace.Flags.IsRemote

        it "keeps a child in its parent's trace" do
            parent <- liftIO $ Span.Context.new Nothing
            child <- liftIO . Span.Context.new $ Just parent
            child.traceId `shouldBe` parent.traceId
            child.spanId `shouldNotBe` parent.spanId

        it "round-trips the example specification header" do
            let traceparent :: ByteString
                traceparent = "00-4bf92f3577b34da6a3ce929d0e0e4736-00f067aa0ba902b7-01"
            case Span.Context.fromTraceparent traceparent of
                Nothing -> expectationFailure "the example specification header did not parse"
                Just ctx -> do
                    headers <- Propagator.w3cTraceContext.inject (Just ctx) mempty
                    lookup "traceparent" headers `shouldBe` Just traceparent

        prop "injects a header of the specified shape" \(ctx :: Context) ->
            case ByteString.split 0x2d (Span.Context.toTraceparent ctx) of
                [version, traceId, spanId, flags] ->
                    ByteString.length
                        <$> [version, traceId, spanId, flags]
                            `shouldBe` [2, 32, 16, 2]
                _ -> expectationFailure "a traceparent has four dash-separated fields"

        it "extracts nothing from headers that carry no context" do
            Propagator.w3cTraceContext.extract mempty Nothing `shouldReturn` Nothing

        it "leaves an existing context alone when none is inbound" do
            ctx <- liftIO $ Span.Context.new Nothing
            Propagator.w3cTraceContext.extract mempty (Just ctx)
                `shouldReturn` Just ctx