diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,28 @@ # Revision history for pgmq-effectful +## 0.3.0.0 -- 2026-05-31 + +### Breaking Changes + +* Now requires the `hs-opentelemetry` 1.0 package family and + `hs-opentelemetry-semantic-conventions` 1.40 (previously the 0.x + series). Downstream projects must upgrade their OpenTelemetry + dependencies to build against this release. + +### New Features + +* `Pgmq.Effectful.Telemetry` re-exports the stable semantic-convention + attribute keys `messaging_operation_name`, `messaging_operation_type`, + `db_system_name`, and `db_operation_name`. +* The traced interpreter now honours `OTEL_SEMCONV_STABILITY_OPT_IN` to + choose old, stable, or duplicate messaging and database attributes. + The default remains compatible with the v1.24 attributes emitted by + 0.2.0.0. Use `OTEL_SEMCONV_STABILITY_OPT_IN=messaging,database` for + stable-only attributes (`messaging.operation.name`, + `messaging.operation.type`, `db.system.name`, `db.operation.name`), + or `messaging/dup,database/dup` to emit both old and stable names + during migration. + ## 0.2.0.0 -- 2026-04-23 ### Breaking Changes diff --git a/pgmq-effectful.cabal b/pgmq-effectful.cabal --- a/pgmq-effectful.cabal +++ b/pgmq-effectful.cabal @@ -1,6 +1,6 @@ cabal-version: 3.4 name: pgmq-effectful -version: 0.2.0.0 +version: 0.3.0.0 synopsis: Effectful effects for PGMQ (PostgreSQL Message Queue) description: Effectful effects and interpreters for pgmq-hs, a Haskell client @@ -54,11 +54,11 @@ , effectful-core ^>=2.5 || ^>=2.6 , hasql ^>=1.10 , hasql-pool ^>=1.4 - , hs-opentelemetry-api >=0.2 && <0.4 - , hs-opentelemetry-semantic-conventions >=0.1 && <0.2 + , hs-opentelemetry-api >=1.0 && <2 + , hs-opentelemetry-semantic-conventions >=1.40 && <2 , http-types >=0.12 && <0.13 - , pgmq-core >=0.2 && <0.3 - , pgmq-hasql >=0.2 && <0.3 + , pgmq-core >=0.3 && <0.4 + , pgmq-hasql >=0.3 && <0.4 , text >=2.0 && <2.2 , unliftio >=0.2 && <0.3 , unordered-containers >=0.2 && <0.3 @@ -95,14 +95,14 @@ , ephemeral-pg >=0.2.1 , hasql ^>=1.10 , hasql-pool ^>=1.4 - , hs-opentelemetry-api >=0.2 && <0.4 - , hs-opentelemetry-exporter-in-memory >=0.0 && <0.1 - , hs-opentelemetry-propagator-w3c >=0.0 && <0.2 - , hs-opentelemetry-sdk >=0.0 && <0.2 - , hs-opentelemetry-semantic-conventions >=0.1 && <0.2 - , pgmq-core >=0.2 && <0.3 + , hs-opentelemetry-api >=1.0 && <2 + , hs-opentelemetry-exporter-in-memory >=1.0 && <2 + , hs-opentelemetry-propagator-w3c >=1.0 && <2 + , hs-opentelemetry-sdk >=1.0 && <2 + , hs-opentelemetry-semantic-conventions >=1.40 && <2 + , pgmq-core >=0.3 && <0.4 , pgmq-effectful - , pgmq-migration >=0.2 && <0.3 + , pgmq-migration >=0.3 && <0.4 , random ^>=1.2 , tasty ^>=1.5 , tasty-hunit ^>=0.10 diff --git a/src/Pgmq/Effectful/Interpreter/Traced.hs b/src/Pgmq/Effectful/Interpreter/Traced.hs --- a/src/Pgmq/Effectful/Interpreter/Traced.hs +++ b/src/Pgmq/Effectful/Interpreter/Traced.hs @@ -6,25 +6,31 @@ -- == OpenTelemetry Semantic Conventions -- -- Spans emitted by this interpreter follow OpenTelemetry --- [Semantic Conventions v1.24](https://github.com/open-telemetry/semantic-conventions/tree/v1.24.0) --- for messaging clients and database clients. +-- [Semantic Conventions v1.40](https://github.com/open-telemetry/semantic-conventions/tree/v1.40.0) +-- for messaging clients and database clients, while preserving the +-- older v1.24 attributes by default unless +-- @OTEL_SEMCONV_STABILITY_OPT_IN@ opts into stable conventions. -- -- For every operation the interpreter emits: -- --- * @db.system = "postgresql"@ --- * @db.operation = "pgmq."@ (for example @"pgmq.send"@, @"pgmq.read"@, --- @"pgmq.archive"@). +-- * default mode: @db.system = "postgresql"@ and +-- @db.operation = "pgmq."@ +-- * @OTEL_SEMCONV_STABILITY_OPT_IN=database@: @db.system.name = "postgresql"@ +-- and @db.operation.name = "pgmq."@ +-- * @OTEL_SEMCONV_STABILITY_OPT_IN=database/dup@: both sets. -- -- For /messaging/ operations (the publish and receive families) the -- interpreter additionally emits: -- -- * @messaging.system = "pgmq"@ --- * @messaging.operation@ — one of @"publish"@ (every @send*@ variant, --- including topic sends) or @"receive"@ (every @read*@ and @pop@ --- variant). The @"process"@ operation is intentionally not emitted --- here — it belongs to the consumer, which should open its own --- @process@ span around application-level handling of a received --- message (see 'Pgmq.Effectful.Traced.readMessageWithContext'). +-- * default mode: @messaging.operation@ — one of @"publish"@ (every +-- @send*@ variant, including topic sends) or @"receive"@ (every +-- @read*@ and @pop@ variant). Stable messaging mode emits +-- @messaging.operation.name@ and @messaging.operation.type@ instead; +-- duplicate mode emits both sets. The @"process"@ operation is +-- intentionally not emitted here — it belongs to the consumer, which +-- should open its own @process@ span around application-level handling +-- of a received message (see 'Pgmq.Effectful.Traced.readMessageWithContext'). -- * @messaging.destination.name@ — the queue name, or for topic sends -- the routing key (which is the logical destination for pgmq topics). -- @@ -87,6 +93,7 @@ import Hasql.Pool qualified as Pool import Hasql.Session qualified import OpenTelemetry.Attributes.Map (AttributeMap, insertByKey) +import OpenTelemetry.SemanticsConfig (StabilityOpt (..), databaseOption, getSemanticsOptions', lookupStability) import OpenTelemetry.Trace.Core qualified as OTel import Pgmq.Effectful.Effect (Pgmq (..)) import Pgmq.Effectful.Interpreter @@ -118,11 +125,11 @@ } -- | Describes how a 'Pgmq' operation maps onto OpenTelemetry semantic --- conventions v1.24. +-- conventions. data OpInfo = OpInfo { -- | The pgmq SQL function being invoked (@"pgmq.send"@ etc.). opDbFunction :: !Text, - -- | The v1.24 @messaging.operation@ verb, if any. One of + -- | The legacy @messaging.operation@ verb, if any. One of -- @"publish"@ or @"receive"@; @Nothing@ for lifecycle/observability -- operations. opMessagingKind :: !(Maybe Text), @@ -383,15 +390,14 @@ Just d -> op <> " " <> d Nothing -> op -operationAttributes :: OpInfo -> AttributeMap -operationAttributes info = +operationAttributesWith :: StabilityOpt -> StabilityOpt -> OpInfo -> AttributeMap +operationAttributesWith dbStability messagingStability info = let base = - insertByKey db_system ("postgresql" :: Text) - . insertByKey db_operation info.opDbFunction + databaseAttributes dbStability info withMsgKind = case info.opMessagingKind of Just mk -> insertByKey messaging_system ("pgmq" :: Text) - . insertByKey messaging_operation mk + . messagingOperationAttributes messagingStability mk Nothing -> id withDest = case info.opDestination of Just d -> insertByKey messaging_destination_name d @@ -405,6 +411,32 @@ Nothing -> id in (withMsgId . withCount . withDest . withMsgKind . base) mempty +databaseAttributes :: StabilityOpt -> OpInfo -> AttributeMap -> AttributeMap +databaseAttributes stability info = case stability of + Old -> + insertByKey db_system ("postgresql" :: Text) + . insertByKey db_operation info.opDbFunction + Stable -> + insertByKey db_system_name ("postgresql" :: Text) + . insertByKey db_operation_name info.opDbFunction + StableAndOld -> + insertByKey db_system ("postgresql" :: Text) + . insertByKey db_operation info.opDbFunction + . insertByKey db_system_name ("postgresql" :: Text) + . insertByKey db_operation_name info.opDbFunction + +messagingOperationAttributes :: StabilityOpt -> Text -> AttributeMap -> AttributeMap +messagingOperationAttributes stability op = case stability of + Old -> + insertByKey messaging_operation op + Stable -> + insertByKey messaging_operation_name op + . insertByKey messaging_operation_type op + StableAndOld -> + insertByKey messaging_operation op + . insertByKey messaging_operation_name op + . insertByKey messaging_operation_type op + withTracedOp :: (IOE :> es, Error PgmqRuntimeError :> es) => TracingConfig -> @@ -413,9 +445,12 @@ Hasql.Session.Session a -> Eff es a withTracedOp config pool info session = do + semOpts <- Effectful.liftIO getSemanticsOptions' + let dbStability = databaseOption semOpts + messagingStability = lookupStability "messaging" semOpts let args = OTel.addAttributesToSpanArguments - (operationAttributes info) + (operationAttributesWith dbStability messagingStability info) OTel.defaultSpanArguments {OTel.kind = info.opSpanKind} result <- Effectful.liftIO $ diff --git a/src/Pgmq/Effectful/Telemetry.hs b/src/Pgmq/Effectful/Telemetry.hs --- a/src/Pgmq/Effectful/Telemetry.hs +++ b/src/Pgmq/Effectful/Telemetry.hs @@ -8,12 +8,14 @@ -- B3, Datadog, …). The pgmq header payload is a JSON object whose -- keys are header names (lower-cased) and whose values are strings. -- * Re-exports of typed 'AttributeKey' values from --- "OpenTelemetry.SemanticConventions" for the v1.24 attributes used --- by the pgmq instrumentation. +-- "OpenTelemetry.SemanticConventions" for the attributes used by the +-- pgmq instrumentation. -- -- The semantic-conventions names mirror OpenTelemetry specification --- v1.24 as generated into @hs-opentelemetry-semantic-conventions@ --- 0.1.0.0. +-- v1.40 as generated into @hs-opentelemetry-semantic-conventions@ +-- 1.40.0.0. The traced interpreter uses +-- @OTEL_SEMCONV_STABILITY_OPT_IN@ to choose old, stable, or duplicate +-- database and messaging operation attributes. module Pgmq.Effectful.Telemetry ( -- * Trace Context Propagation injectTraceContext, @@ -31,8 +33,12 @@ messaging_destination_name, messaging_message_id, messaging_batch_messageCount, + messaging_operation_name, + messaging_operation_type, db_system, db_operation, + db_system_name, + db_operation_name, ) where @@ -45,14 +51,26 @@ import Data.Text.Encoding qualified as TE import Network.HTTP.Types (RequestHeaders) import OpenTelemetry.Context qualified as Ctxt -import OpenTelemetry.Propagator (Propagator, extract, inject) +import OpenTelemetry.Propagator + ( TextMap, + TextMapPropagator, + emptyTextMap, + extract, + inject, + textMapFromList, + textMapToList, + ) import OpenTelemetry.SemanticConventions ( db_operation, + db_operation_name, db_system, + db_system_name, messaging_batch_messageCount, messaging_destination_name, messaging_message_id, messaging_operation, + messaging_operation_name, + messaging_operation_type, messaging_system, ) import OpenTelemetry.Trace.Core @@ -94,16 +112,37 @@ m Ctxt.Context extractTraceContext provider headers ctxt = let propagator = getTracerProviderPropagators provider - in extract propagator headers ctxt + in extract propagator (traceHeadersToTextMap headers) ctxt -- | Propagator-generic inject wrapper (mainly useful for tests that -- want to pin the propagator explicitly). injectWith :: (MonadIO m) => - Propagator Ctxt.Context RequestHeaders RequestHeaders -> + TextMapPropagator -> Ctxt.Context -> m TraceHeaders -injectWith propagator ctxt = liftIO $ inject propagator ctxt [] +injectWith propagator ctxt = + liftIO $ textMapToTraceHeaders <$> inject propagator ctxt emptyTextMap + +traceHeadersToTextMap :: TraceHeaders -> TextMap +traceHeadersToTextMap = + textMapFromList + . fmap + ( \(name, value) -> + ( TE.decodeUtf8 (CI.foldedCase name), + TE.decodeUtf8 value + ) + ) + +textMapToTraceHeaders :: TextMap -> TraceHeaders +textMapToTraceHeaders = + fmap + ( \(name, value) -> + ( CI.mk (TE.encodeUtf8 name), + TE.encodeUtf8 value + ) + ) + . textMapToList -- | Encode carrier headers as a JSON object for storage in pgmq -- message headers (jsonb). Header names are lower-cased (via diff --git a/test/TracedInterpreterSpec.hs b/test/TracedInterpreterSpec.hs --- a/test/TracedInterpreterSpec.hs +++ b/test/TracedInterpreterSpec.hs @@ -2,8 +2,9 @@ module TracedInterpreterSpec (tests) where +import Control.Concurrent.MVar (MVar, newMVar, putMVar, takeMVar) +import Control.Exception (bracket) import Control.Monad (unless) -import Control.Monad.IO.Class (liftIO) import Data.HashMap.Strict qualified as HM import Data.IORef (IORef, readIORef) import Data.Text (Text) @@ -16,7 +17,6 @@ import OpenTelemetry.Context qualified as Ctxt import OpenTelemetry.Context.ThreadLocal qualified as CtxtLocal import OpenTelemetry.Exporter.InMemory.Span qualified as InMemoryExporter -import OpenTelemetry.Propagator (extract) import OpenTelemetry.Propagator.W3CTraceContext qualified as W3C import OpenTelemetry.Trace.Core qualified as OTel import OpenTelemetry.Trace.Id.Generator.Default (defaultIdGenerator) @@ -38,8 +38,10 @@ sendMessage, sendMessageTraced, ) -import Pgmq.Effectful.Telemetry (jsonToTraceHeaders) +import Pgmq.Effectful.Telemetry (extractTraceContext, jsonToTraceHeaders) import Pgmq.Types qualified as Pgmq +import System.Environment (lookupEnv, setEnv, unsetEnv) +import System.IO.Unsafe (unsafePerformIO) import System.Random (randomRIO) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (assertBool, assertEqual, assertFailure, testCase) @@ -72,75 +74,131 @@ "Expected an error, got success" ], testGroup - "v1.24 semantic conventions" - [ testCase "publish emits messaging.* + db.* attributes" $ do - (tracer, _provider, spansRef) <- setupTracer - queue <- mkUniqueQueue "publish_attrs" - result <- - runEff . runError @PgmqRuntimeError . runPgmqTraced pool tracer $ do - createQueue queue - sendMessage - SendMessage - { queueName = queue, - messageBody = MessageBody "hello", - delay = Nothing - } - _ <- assertRight result - spans <- readIORef spansRef - let publishSpans = filter ((==) "publish" . firstWord . OTel.spanName) spans - unless (length publishSpans == 1) $ - assertFailure $ - "Expected exactly one publish span, got " - <> show (map OTel.spanName spans) - s <- singleSpan publishSpans "publish" - assertEqual - "span name carries destination" - ("publish " <> queueNameToText queue) - (OTel.spanName s) - assertSpanKindProducer s - assertAttrText s "messaging.system" "pgmq" - assertAttrText s "messaging.operation" "publish" - assertAttrText s "messaging.destination.name" (queueNameToText queue) - assertAttrText s "db.system" "postgresql" - assertAttrText s "db.operation" "pgmq.send", - testCase "receive emits messaging.* + db.* attributes" $ do - (tracer, _provider, spansRef) <- setupTracer - queue <- mkUniqueQueue "receive_attrs" - result <- - runEff . runError @PgmqRuntimeError . runPgmqTraced pool tracer $ do - createQueue queue - _ <- + "semantic conventions" + [ testCase "publish emits messaging.* + db.* attributes" $ + withSemconvOptIn "" $ do + (tracer, _provider, spansRef) <- setupTracer + queue <- mkUniqueQueue "publish_attrs" + result <- + runEff . runError @PgmqRuntimeError . runPgmqTraced pool tracer $ do + createQueue queue sendMessage SendMessage { queueName = queue, - messageBody = MessageBody "one", + messageBody = MessageBody "hello", delay = Nothing } - readMessage - ReadMessage - { queueName = queue, - delay = 30, - batchSize = Just 1, - conditional = Nothing - } - _ <- assertRight result - spans <- readIORef spansRef - let receiveSpans = filter ((==) "receive" . firstWord . OTel.spanName) spans - unless (length receiveSpans == 1) $ - assertFailure $ - "Expected exactly one receive span, got " - <> show (map OTel.spanName spans) - s <- singleSpan receiveSpans "receive" - assertEqual - "span name carries destination" - ("receive " <> queueNameToText queue) - (OTel.spanName s) - assertSpanKindConsumer s - assertAttrText s "messaging.system" "pgmq" - assertAttrText s "messaging.operation" "receive" - assertAttrText s "messaging.destination.name" (queueNameToText queue) - assertAttrText s "db.system" "postgresql" - assertAttrText s "db.operation" "pgmq.read", + _ <- assertRight result + spans <- readIORef spansRef + publishSpans <- spansWithFirstWord "publish" spans + unless (length publishSpans == 1) $ + spanNames spans >>= \names -> + assertFailure $ + "Expected exactly one publish span, got " + <> show names + s <- singleSpan publishSpans "publish" + actualSpanName <- spanName s + assertEqual + "span name carries destination" + ("publish " <> queueNameToText queue) + actualSpanName + assertSpanKindProducer s + assertAttrText s "messaging.system" "pgmq" + assertAttrText s "messaging.operation" "publish" + assertAttrText s "messaging.destination.name" (queueNameToText queue) + assertAttrText s "db.system" "postgresql" + assertAttrText s "db.operation" "pgmq.send", + testCase "receive emits messaging.* + db.* attributes" $ + withSemconvOptIn "" $ do + (tracer, _provider, spansRef) <- setupTracer + queue <- mkUniqueQueue "receive_attrs" + result <- + runEff . runError @PgmqRuntimeError . runPgmqTraced pool tracer $ do + createQueue queue + _ <- + sendMessage + SendMessage + { queueName = queue, + messageBody = MessageBody "one", + delay = Nothing + } + readMessage + ReadMessage + { queueName = queue, + delay = 30, + batchSize = Just 1, + conditional = Nothing + } + _ <- assertRight result + spans <- readIORef spansRef + receiveSpans <- spansWithFirstWord "receive" spans + unless (length receiveSpans == 1) $ + spanNames spans >>= \names -> + assertFailure $ + "Expected exactly one receive span, got " + <> show names + s <- singleSpan receiveSpans "receive" + actualSpanName <- spanName s + assertEqual + "span name carries destination" + ("receive " <> queueNameToText queue) + actualSpanName + assertSpanKindConsumer s + assertAttrText s "messaging.system" "pgmq" + assertAttrText s "messaging.operation" "receive" + assertAttrText s "messaging.destination.name" (queueNameToText queue) + assertAttrText s "db.system" "postgresql" + assertAttrText s "db.operation" "pgmq.read", + testCase "stable opt-in emits stable messaging and database attributes" $ + withSemconvOptIn "messaging,database" $ do + (tracer, _provider, spansRef) <- setupTracer + queue <- mkUniqueQueue "stable_attrs" + result <- + runEff . runError @PgmqRuntimeError . runPgmqTraced pool tracer $ do + createQueue queue + sendMessage + SendMessage + { queueName = queue, + messageBody = MessageBody "hello", + delay = Nothing + } + _ <- assertRight result + spans <- readIORef spansRef + publishSpans <- spansWithFirstWord "publish" spans + s <- singleSpan publishSpans "publish" + assertAttrText s "messaging.system" "pgmq" + assertNoAttr s "messaging.operation" + assertAttrText s "messaging.operation.name" "publish" + assertAttrText s "messaging.operation.type" "publish" + assertAttrText s "messaging.destination.name" (queueNameToText queue) + assertNoAttr s "db.system" + assertNoAttr s "db.operation" + assertAttrText s "db.system.name" "postgresql" + assertAttrText s "db.operation.name" "pgmq.send", + testCase "dup opt-in emits old and stable messaging and database attributes" $ + withSemconvOptIn "messaging/dup,database/dup" $ do + (tracer, _provider, spansRef) <- setupTracer + queue <- mkUniqueQueue "dup_attrs" + result <- + runEff . runError @PgmqRuntimeError . runPgmqTraced pool tracer $ do + createQueue queue + sendMessage + SendMessage + { queueName = queue, + messageBody = MessageBody "hello", + delay = Nothing + } + _ <- assertRight result + spans <- readIORef spansRef + publishSpans <- spansWithFirstWord "publish" spans + s <- singleSpan publishSpans "publish" + assertAttrText s "messaging.operation" "publish" + assertAttrText s "messaging.operation.name" "publish" + assertAttrText s "messaging.operation.type" "publish" + assertAttrText s "db.system" "postgresql" + assertAttrText s "db.operation" "pgmq.send" + assertAttrText s "db.system.name" "postgresql" + assertAttrText s "db.operation.name" "pgmq.send", testCase "error path records exception event and Error status" $ do (tracer, _provider, spansRef) <- setupTracer bogus <- mkQueueName "queue_that_does_not_exist_xyz3" @@ -154,18 +212,20 @@ s <- case spans of [only] -> pure only _ -> - assertFailure - ( "Expected exactly one span, got " - <> show (map OTel.spanName spans) - ) - >> fail "" + spanNames spans >>= \names -> + assertFailure + ( "Expected exactly one span, got " + <> show names + ) + >> fail "" + hot <- readIORef (OTel.spanHot s) let events = V.toList - (appendOnlyBoundedCollectionValues (OTel.spanEvents s)) + (appendOnlyBoundedCollectionValues (OTel.hotEvents hot)) hasExceptionEvent = any ((==) "exception" . OTel.eventName) events assertBool "span has exception event" hasExceptionEvent - case OTel.spanStatus s of + case OTel.hotStatus hot of OTel.Error desc -> assertBool ( "span status description should be a short non-PII label, got " @@ -208,10 +268,8 @@ assertFailure "expected trace headers on received message, got none" Just hdrs -> do - let propagator = OTel.getTracerProviderPropagators provider ctx <- - liftIO $ - extract propagator (jsonToTraceHeaders hdrs) Ctxt.empty + extractTraceContext provider (jsonToTraceHeaders hdrs) Ctxt.empty case Ctxt.lookupSpan ctx of Nothing -> assertFailure $ @@ -261,6 +319,18 @@ firstWord :: Text -> Text firstWord = T.takeWhile (/= ' ') +spanName :: OTel.ImmutableSpan -> IO Text +spanName s = OTel.hotName <$> readIORef (OTel.spanHot s) + +spanNames :: [OTel.ImmutableSpan] -> IO [Text] +spanNames = traverse spanName + +spansWithFirstWord :: Text -> [OTel.ImmutableSpan] -> IO [OTel.ImmutableSpan] +spansWithFirstWord word spans = + fmap + (fmap fst . filter ((==) word . firstWord . snd)) + (traverse (\s -> do name <- spanName s; pure (s, name)) spans) + assertRight :: (Show a) => Either a b -> IO b assertRight = \case Right b -> pure b @@ -271,13 +341,14 @@ singleSpan spans label = case spans of [s] -> pure s _ -> - assertFailure - ( "expected exactly one " - <> label - <> " span, got " - <> show (map OTel.spanName spans) - ) - >> fail "" + spanNames spans >>= \names -> + assertFailure + ( "expected exactly one " + <> label + <> " span, got " + <> show names + ) + >> fail "" -- | 'OTel.SpanKind' has no 'Eq' instance, so assert via pattern. assertSpanKindProducer :: OTel.ImmutableSpan -> IO () @@ -295,7 +366,8 @@ -- attribute map when the assertion fails. assertAttrText :: OTel.ImmutableSpan -> Text -> Text -> IO () assertAttrText s key expected = do - let attrMap = Attrs.getAttributeMap (OTel.spanAttributes s) + hot <- readIORef (OTel.spanHot s) + let attrMap = Attrs.getAttributeMap (OTel.hotAttributes hot) case HM.lookup key attrMap of Just (Attrs.AttributeValue (Attrs.TextAttribute actual)) -> assertEqual ("attribute " <> T.unpack key) expected actual @@ -309,3 +381,34 @@ <> show other <> " in " <> show attrMap + +assertNoAttr :: OTel.ImmutableSpan -> Text -> IO () +assertNoAttr s key = do + hot <- readIORef (OTel.spanHot s) + let attrMap = Attrs.getAttributeMap (OTel.hotAttributes hot) + case HM.lookup key attrMap of + Nothing -> pure () + Just actual -> + assertFailure $ + "expected no attribute " + <> T.unpack key + <> "; got " + <> show actual + <> " in " + <> show attrMap + +withSemconvOptIn :: String -> IO a -> IO a +withSemconvOptIn value action = + bracket + (takeMVar semconvEnvLock *> (lookupEnv var <* setEnv var value)) + restore + (const action) + where + var = "OTEL_SEMCONV_STABILITY_OPT_IN" + restore = \case + Nothing -> unsetEnv var *> putMVar semconvEnvLock () + Just old -> setEnv var old *> putMVar semconvEnvLock () + +semconvEnvLock :: MVar () +semconvEnvLock = unsafePerformIO (newMVar ()) +{-# NOINLINE semconvEnvLock #-}