hs-opentelemetry-propagator-jaeger (empty) → 1.0.0.0
raw patch · 8 files changed
+821/−0 lines, 8 filesdep +basedep +bytestringdep +hs-opentelemetry-api
Dependencies added: base, bytestring, hs-opentelemetry-api, hs-opentelemetry-propagator-jaeger, hspec, text, unordered-containers
Files
- ChangeLog.md +12/−0
- LICENSE +30/−0
- README.md +14/−0
- hs-opentelemetry-propagator-jaeger.cabal +72/−0
- src/OpenTelemetry/Propagator/Jaeger.hs +150/−0
- src/OpenTelemetry/Propagator/Jaeger/Internal.hs +226/−0
- test/OpenTelemetry/Propagator/JaegerSpec.hs +315/−0
- test/Spec.hs +2/−0
+ ChangeLog.md view
@@ -0,0 +1,12 @@+# Changelog for hs-opentelemetry-propagator-jaeger++## 1.0.0.0 - 2026-05-29++- Promoted to 1.0.0.0 for the hs-opentelemetry 1.0 release.++## 0.0.1.0++- Initial release.+- Extract and inject `uber-trace-id` (Jaeger trace context) header.+- Extract and inject `uberctx-*` (Jaeger baggage) headers.+- Registry integration under the name `"jaeger"`.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Ian Duncan (c) 2024-2026++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Ian Duncan nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,14 @@+# hs-opentelemetry-propagator-jaeger++[](https://hackage.haskell.org/package/hs-opentelemetry-propagator-jaeger)++Jaeger trace context propagation for the+[hs-opentelemetry](https://github.com/iand675/hs-opentelemetry) suite.++Implements the `uber-trace-id` header format and `uberctx-*` baggage+headers as described in the+[Jaeger propagation format](https://www.jaegertracing.io/docs/1.21/client-libraries/#propagation-format).++> **Note:** The Jaeger propagation format is deprecated in favor of+> [W3C Trace Context](https://www.w3.org/TR/trace-context/). Use this+> package for interoperability with legacy systems only.
+ hs-opentelemetry-propagator-jaeger.cabal view
@@ -0,0 +1,72 @@+cabal-version: 2.4++name: hs-opentelemetry-propagator-jaeger+version: 1.0.0.0+synopsis: Jaeger trace context propagation for OpenTelemetry.+description:+ Propagator implementing the Jaeger trace context format+ (@uber-trace-id@ header) and Jaeger baggage (@uberctx-*@ headers).+ .+ The Jaeger format is deprecated in favour of W3C Trace Context but is+ still widely deployed. This package lets Haskell services interoperate+ with legacy Jaeger-instrumented systems.+ .+ See <https://www.jaegertracing.io/docs/1.21/client-libraries/#propagation-format>.+category: OpenTelemetry, Tracing, Web+homepage: https://github.com/iand675/hs-opentelemetry#readme+bug-reports: https://github.com/iand675/hs-opentelemetry/issues+author: Ian Duncan+maintainer: ian@iankduncan.com+copyright: 2024 Ian Duncan, Mercury Technologies+license: BSD-3-Clause+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+extra-doc-files:+ ChangeLog.md++source-repository head+ type: git+ location: https://github.com/iand675/hs-opentelemetry++library+ exposed-modules:+ OpenTelemetry.Propagator.Jaeger+ OpenTelemetry.Propagator.Jaeger.Internal+ other-modules:+ Paths_hs_opentelemetry_propagator_jaeger+ autogen-modules:+ Paths_hs_opentelemetry_propagator_jaeger+ hs-source-dirs:+ src+ ghc-options: -Wall+ build-depends:+ base >=4.7 && <5+ , bytestring+ , hs-opentelemetry-api ^>= 1.0+ , text+ , unordered-containers+ default-language: Haskell2010++test-suite hs-opentelemetry-propagator-jaeger-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ OpenTelemetry.Propagator.JaegerSpec+ Paths_hs_opentelemetry_propagator_jaeger+ autogen-modules:+ Paths_hs_opentelemetry_propagator_jaeger+ hs-source-dirs:+ test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base >=4.7 && <5+ , bytestring+ , hs-opentelemetry-api ^>= 1.0+ , hs-opentelemetry-propagator-jaeger ^>= 1.0+ , hspec+ , text+ , unordered-containers+ default-language: Haskell2010+ build-tool-depends: hspec-discover:hspec-discover
+ src/OpenTelemetry/Propagator/Jaeger.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++{- | Jaeger Propagation Format:+ <https://www.jaegertracing.io/docs/1.21/client-libraries/#propagation-format>++ The Jaeger propagation format is deprecated in favour of W3C Trace+ Context. This package exists for interoperability with legacy systems.++ == Header: @uber-trace-id@++ @+ {trace-id}:{span-id}:{parent-span-id}:{flags}+ @++ == Baggage: @uberctx-{key}@++ Each baggage entry is a separate header with prefix @uberctx-@.+-}+module OpenTelemetry.Propagator.Jaeger (+ jaegerPropagator,+ jaegerTraceContextPropagator,++ -- * Registry integration+ registerJaegerPropagator,+) where++import qualified Data.ByteString.Char8 as C+import qualified Data.HashMap.Strict as H+import Data.Maybe (catMaybes)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import OpenTelemetry.Baggage (decodeBaggageHeader)+import qualified OpenTelemetry.Baggage as Baggage+import OpenTelemetry.Common (TraceFlags (..))+import OpenTelemetry.Context (Context)+import qualified OpenTelemetry.Context as Context+import OpenTelemetry.Propagator (+ Propagator (..),+ TextMap,+ textMapInsert,+ textMapKeys,+ textMapLookup,+ )+import OpenTelemetry.Propagator.Jaeger.Internal+import OpenTelemetry.Registry (registerTextMapPropagator)+import qualified OpenTelemetry.Trace.Core as Core+import OpenTelemetry.Trace.TraceState (TraceState (..))+++{- | Propagator for the Jaeger trace context format.++Handles both the @uber-trace-id@ header (trace context) and+@uberctx-*@ headers (baggage).+-}+jaegerPropagator :: Propagator Context TextMap TextMap+jaegerPropagator = jaegerTraceContextPropagator <> jaegerBaggagePropagator+++{- | Propagator for the @uber-trace-id@ header only (no baggage).++Use 'jaegerPropagator' if you also need Jaeger baggage propagation.+-}+jaegerTraceContextPropagator :: Propagator Context TextMap TextMap+jaegerTraceContextPropagator =+ Propagator+ { propagatorFields = [uberTraceIdHeader]+ , extractor = \tm c ->+ case textMapLookup uberTraceIdHeader tm of+ Nothing -> pure c+ Just val ->+ case decodeUberTraceId (TE.encodeUtf8 val) of+ Nothing -> pure c+ Just jh ->+ let sampled = flagsSampled (jhFlags jh) || flagsDebug (jhFlags jh)+ sc =+ Core.SpanContext+ { Core.traceId = jhTraceId jh+ , Core.spanId = jhSpanId jh+ , Core.isRemote = True+ , Core.traceFlags = if sampled then TraceFlags 1 else TraceFlags 0+ , Core.traceState = TraceState []+ }+ in pure $ Context.insertSpan (Core.wrapSpanContext sc) c+ , injector = \c tm ->+ case Context.lookupSpan c of+ Nothing -> pure tm+ Just span' -> do+ sc <- Core.getSpanContext span'+ let !sampled = Core.isSampled (Core.traceFlags sc)+ !headerBs = encodeUberTraceId (Core.traceId sc) (Core.spanId sc) sampled+ !headerValue = TE.decodeUtf8 headerBs+ pure $ textMapInsert uberTraceIdHeader headerValue tm+ }+++-- | Propagator for Jaeger-style baggage (@uberctx-*@ headers).+jaegerBaggagePropagator :: Propagator Context TextMap TextMap+jaegerBaggagePropagator =+ Propagator+ { propagatorFields = []+ , extractor = \tm c -> do+ let baggageKeys = filter (T.isPrefixOf uberBaggagePrefix) (textMapKeys tm)+ entries = catMaybes $ map (extractBaggageEntry tm) baggageKeys+ case entries of+ [] -> pure c+ kvs ->+ case decodeBaggageHeader (C.pack $ encodeBaggageString kvs) of+ Left _ -> pure c+ Right bag -> pure $ Context.insertBaggage bag c+ , injector = \c tm ->+ case Context.lookupBaggage c of+ Nothing -> pure tm+ Just bag ->+ let entries = H.toList (Baggage.values bag)+ in pure $+ foldl+ ( \acc (k, v) ->+ let headerName = uberBaggagePrefix <> TE.decodeUtf8 (Baggage.tokenValue k)+ in textMapInsert headerName (Baggage.value v) acc+ )+ tm+ entries+ }+++extractBaggageEntry :: TextMap -> Text -> Maybe (Text, Text)+extractBaggageEntry tm headerKey = do+ val <- textMapLookup headerKey tm+ let key = T.drop (T.length uberBaggagePrefix) headerKey+ if T.null key+ then Nothing+ else Just (key, val)+++encodeBaggageString :: [(Text, Text)] -> String+encodeBaggageString kvs =+ T.unpack $ T.intercalate "," $ map (\(k, v) -> k <> "=" <> v) kvs+++{- | Register the Jaeger propagator under the name @\"jaeger\"@ in the+global registry.++@since 0.0.1.0+-}+registerJaegerPropagator :: IO ()+registerJaegerPropagator =+ registerTextMapPropagator "jaeger" jaegerPropagator
+ src/OpenTelemetry/Propagator/Jaeger/Internal.hs view
@@ -0,0 +1,226 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Strict #-}++{- | Internal codec for the Jaeger propagation format.++The wire format for the @uber-trace-id@ header is:++@+{trace-id}:{span-id}:{parent-span-id}:{flags}+@++See <https://www.jaegertracing.io/docs/1.21/client-libraries/#propagation-format>.+-}+module OpenTelemetry.Propagator.Jaeger.Internal (+ -- * Encoders+ encodeTraceId,+ encodeSpanId,+ encodeUberTraceId,++ -- * Decoders+ decodeUberTraceId,++ -- * Parsed header+ JaegerHeader (..),++ -- * Flags+ JaegerFlags (..),+ flagsSampled,+ flagsDebug,++ -- * Header keys+ uberTraceIdHeader,+ uberBaggagePrefix,+) where++import Data.Bits (Bits ((.&.)))+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import Data.Text (Text)+import Data.Word (Word8)+import OpenTelemetry.Trace.Id (+ Base (..),+ SpanId,+ TraceId,+ baseEncodedToSpanId,+ baseEncodedToTraceId,+ bytesToTraceId,+ spanIdBaseEncodedByteString,+ spanIdBytes,+ traceIdBaseEncodedByteString,+ )+++-- Header keys ----------------------------------------------------------------++uberTraceIdHeader :: Text+uberTraceIdHeader = "uber-trace-id"+++uberBaggagePrefix :: Text+uberBaggagePrefix = "uberctx-"+++-- Flags ----------------------------------------------------------------------++-- | Jaeger flags byte from the wire format.+newtype JaegerFlags = JaegerFlags Word8+ deriving (Eq, Show)+++flagsSampled :: JaegerFlags -> Bool+flagsSampled (JaegerFlags f) = f .&. 0x01 /= 0+++flagsDebug :: JaegerFlags -> Bool+flagsDebug (JaegerFlags f) = f .&. 0x02 /= 0+++-- Parsed header --------------------------------------------------------------++data JaegerHeader = JaegerHeader+ { jhTraceId :: !TraceId+ , jhSpanId :: !SpanId+ , jhParentSpanId :: !(Maybe SpanId)+ , jhFlags :: !JaegerFlags+ }+ deriving (Eq, Show)+++-- Encoders -------------------------------------------------------------------++encodeTraceId :: TraceId -> ByteString+encodeTraceId = traceIdBaseEncodedByteString Base16+{-# INLINE encodeTraceId #-}+++encodeSpanId :: SpanId -> ByteString+encodeSpanId = spanIdBaseEncodedByteString Base16+{-# INLINE encodeSpanId #-}+++{- | Encode a Jaeger uber-trace-id header value directly as a ByteString.++Format: @{trace-id}:{span-id}:0:{flags}@+-}+encodeUberTraceId :: TraceId -> SpanId -> Bool -> ByteString+encodeUberTraceId tid sid sampled =+ traceIdBaseEncodedByteString Base16 tid+ <> ":"+ <> spanIdBaseEncodedByteString Base16 sid+ <> ":0:"+ <> if sampled then "1" else "0"+++-- Decoders -------------------------------------------------------------------++{- | Maximum allowed size for a Jaeger uber-trace-id header in bytes.++The standard format is ~69 bytes:+@{32hex-tid}:{16hex-sid}:{16hex-parent}:{2hex-flags}@++We allow 512 bytes to prevent DoS from scanning arbitrarily large+malformed inputs. This is well below typical web server header limits+(8KB-50KB).+-}+maxHeaderSize :: Int+maxHeaderSize = 512+++{- | Decode a Jaeger @uber-trace-id@ header value.++Uses memchr to locate colon delimiters and the existing SIMD hex+decoders for trace/span ID parsing.+-}+decodeUberTraceId :: ByteString -> Maybe JaegerHeader+decodeUberTraceId bs = do+ let !len = BS.length bs+ -- Reject oversized headers to prevent DoS.+ if len > maxHeaderSize+ then Nothing+ -- Need at least: 16 (tid) + 1 (:) + 1 (sid) + 1 (:) + 1 (parent) + 1 (:) + 1 (flags) = 22+ else+ if len < 22+ then Nothing+ else do+ -- Find three colons via memchr.+ !c1 <- BS.elemIndex 0x3a bs+ !c2rel <- BS.elemIndex 0x3a (BS.drop (c1 + 1) bs)+ let !c2 = c1 + 1 + c2rel+ !c3rel <- BS.elemIndex 0x3a (BS.drop (c2 + 1) bs)+ let !c3 = c2 + 1 + c3rel++ -- Reject extra colons (trailing garbage).+ case BS.elemIndex 0x3a (BS.drop (c3 + 1) bs) of+ Just _ -> Nothing+ Nothing -> do+ let !tidHex = BS.take c1 bs+ !sidHex = BS.take c2rel (BS.drop (c1 + 1) bs)+ !parentHex = BS.take c3rel (BS.drop (c2 + 1) bs)+ !flagsHex = BS.drop (c3 + 1) bs++ -- Flags: 1-2 hex digits, validated first (cheapest check).+ !flags <- parseFlags flagsHex++ -- Trace ID: 16 or 32 hex chars.+ !tid <- eitherToMaybe (decodeTraceIdFromHex tidHex)++ -- Span ID: must be valid hex (length validated by baseEncodedToSpanId).+ !sid <- eitherToMaybe (baseEncodedToSpanId Base16 sidHex)++ -- Parent span ID: all-zeros means "no parent".+ let !parentSid+ | BS.null parentHex = Nothing+ | BS.all (== 0x30) parentHex = Nothing+ | otherwise = eitherToMaybe (baseEncodedToSpanId Base16 parentHex)++ pure+ JaegerHeader+ { jhTraceId = tid+ , jhSpanId = sid+ , jhParentSpanId = parentSid+ , jhFlags = flags+ }+++-- Internal helpers -----------------------------------------------------------++{- | Decode a trace ID from hex, accepting both 64-bit (16 chars, zero-padded)+and 128-bit (32 chars) representations.+-}+decodeTraceIdFromHex :: ByteString -> Either String TraceId+decodeTraceIdFromHex hexBs+ | BS.length hexBs == 32 = baseEncodedToTraceId Base16 hexBs+ | BS.length hexBs == 16 = do+ sid <- baseEncodedToSpanId Base16 hexBs+ bytesToTraceId (BS.replicate 8 0 <> spanIdBytes sid)+ | otherwise = Left "Jaeger trace id: expected 16 or 32 hex characters"+++-- | Parse 1-2 hex characters into a flags byte.+parseFlags :: ByteString -> Maybe JaegerFlags+parseFlags flagsHex = case BS.length flagsHex of+ 1 -> do+ !a <- hexNibble (BS.index flagsHex 0)+ Just $! JaegerFlags a+ 2 -> do+ !a <- hexNibble (BS.index flagsHex 0)+ !b <- hexNibble (BS.index flagsHex 1)+ Just $! JaegerFlags (a * 16 + b)+ _ -> Nothing+++hexNibble :: Word8 -> Maybe Word8+hexNibble c+ | c >= 0x30 && c <= 0x39 = Just (c - 0x30)+ | c >= 0x41 && c <= 0x46 = Just (c - 0x41 + 10)+ | c >= 0x61 && c <= 0x66 = Just (c - 0x61 + 10)+ | otherwise = Nothing+{-# INLINE hexNibble #-}+++eitherToMaybe :: Either a b -> Maybe b+eitherToMaybe (Right x) = Just x+eitherToMaybe (Left _) = Nothing+{-# INLINE eitherToMaybe #-}
+ test/OpenTelemetry/Propagator/JaegerSpec.hs view
@@ -0,0 +1,315 @@+{-# LANGUAGE OverloadedStrings #-}++module OpenTelemetry.Propagator.JaegerSpec (spec) where++import qualified Data.ByteString as BS+import qualified Data.HashMap.Strict as H+import Data.Maybe (isNothing)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified OpenTelemetry.Baggage as Baggage+import OpenTelemetry.Common (TraceFlags (..))+import OpenTelemetry.Context (Context, empty, insertBaggage, insertSpan, lookupBaggage, lookupSpan)+import OpenTelemetry.Propagator (+ Propagator (..),+ TextMap,+ emptyTextMap,+ textMapFromList,+ textMapKeys,+ textMapLookup,+ )+import OpenTelemetry.Propagator.Jaeger (jaegerPropagator, jaegerTraceContextPropagator)+import qualified OpenTelemetry.Propagator.Jaeger.Internal as JI+import OpenTelemetry.Trace.Core (SpanContext (..), getSpanContext, isSampled, wrapSpanContext)+import OpenTelemetry.Trace.Id (Base (..), SpanId, TraceId, baseEncodedToSpanId, baseEncodedToTraceId)+import OpenTelemetry.Trace.TraceState (TraceState (..))+import Test.Hspec+++spec :: Spec+spec =+ -- Jaeger uber-trace-id and uberctx-* propagation+ -- https://www.jaegertracing.io/docs/1.21/client-libraries/#propagation-format+ describe "OpenTelemetry.Propagator.Jaeger" $ do+ describe "Internal codec" $ do+ -- {trace-id}:{span-id}:{parent-span-id}:{flags} (hex)+ -- https://www.jaegertracing.io/docs/1.21/client-libraries/#propagation-format+ it "parses a 128-bit trace context header" $ do+ let hdr = "80f198ee56343ba864fe8b2a57d3eff7:e457b5a2e4d86bd1:0:1"+ case JI.decodeUberTraceId (TE.encodeUtf8 hdr) of+ Nothing -> expectationFailure "expected parse"+ Just jh -> do+ JI.jhTraceId jh `shouldBe` expectedTraceId+ JI.jhSpanId jh `shouldBe` expectedSpanId+ JI.jhParentSpanId jh `shouldBe` Nothing+ JI.flagsSampled (JI.jhFlags jh) `shouldBe` True+ JI.flagsDebug (JI.jhFlags jh) `shouldBe` False++ it "parses a 64-bit trace ID (left-padded to 128-bit)" $ do+ let hdr = "64fe8b2a57d3eff7:e457b5a2e4d86bd1:0:1"+ case JI.decodeUberTraceId (TE.encodeUtf8 hdr) of+ Nothing -> expectationFailure "expected parse"+ Just jh -> do+ JI.jhTraceId jh `shouldBe` expectedTraceId64+ JI.flagsSampled (JI.jhFlags jh) `shouldBe` True++ -- flags: sampled + debug bits+ -- https://www.jaegertracing.io/docs/1.21/client-libraries/#propagation-format+ it "parses debug flag (flags=03 means sampled+debug)" $ do+ let hdr = "80f198ee56343ba864fe8b2a57d3eff7:e457b5a2e4d86bd1:0:03"+ case JI.decodeUberTraceId (TE.encodeUtf8 hdr) of+ Nothing -> expectationFailure "expected parse"+ Just jh -> do+ JI.flagsSampled (JI.jhFlags jh) `shouldBe` True+ JI.flagsDebug (JI.jhFlags jh) `shouldBe` True++ it "parses unsampled flag (flags=0)" $ do+ let hdr = "80f198ee56343ba864fe8b2a57d3eff7:e457b5a2e4d86bd1:0:0"+ case JI.decodeUberTraceId (TE.encodeUtf8 hdr) of+ Nothing -> expectationFailure "expected parse"+ Just jh -> do+ JI.flagsSampled (JI.jhFlags jh) `shouldBe` False+ JI.flagsDebug (JI.jhFlags jh) `shouldBe` False++ it "parses debug-only flag (flags=2)" $ do+ let hdr = "80f198ee56343ba864fe8b2a57d3eff7:e457b5a2e4d86bd1:0:2"+ case JI.decodeUberTraceId (TE.encodeUtf8 hdr) of+ Nothing -> expectationFailure "expected parse"+ Just jh -> do+ JI.flagsSampled (JI.jhFlags jh) `shouldBe` False+ JI.flagsDebug (JI.jhFlags jh) `shouldBe` True++ it "parses non-zero parent span ID" $ do+ let hdr = "80f198ee56343ba864fe8b2a57d3eff7:e457b5a2e4d86bd1:05e3ac9a4f6e3b90:1"+ case JI.decodeUberTraceId (TE.encodeUtf8 hdr) of+ Nothing -> expectationFailure "expected parse"+ Just jh -> case JI.jhParentSpanId jh of+ Nothing -> expectationFailure "expected parent span ID"+ Just _ -> pure ()++ it "rejects empty input" $ do+ JI.decodeUberTraceId "" `shouldBe` Nothing++ it "rejects missing fields" $ do+ JI.decodeUberTraceId "abc:def:0" `shouldBe` Nothing++ it "rejects non-hex characters in trace ID" $ do+ JI.decodeUberTraceId "zzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzz:e457b5a2e4d86bd1:0:1"+ `shouldBe` Nothing++ it "rejects trailing garbage" $ do+ JI.decodeUberTraceId "80f198ee56343ba864fe8b2a57d3eff7:e457b5a2e4d86bd1:0:1:extra"+ `shouldBe` Nothing++ it "rejects oversized header (> 512 bytes)" $ do+ -- Create a header with valid format but padded to exceed 512 bytes+ let validPart = "80f198ee56343ba864fe8b2a57d3eff7:e457b5a2e4d86bd1:0:1"+ -- Add enough hex chars to exceed 512 bytes (valid part is ~47 bytes)+ padding = replicate (512 - BS.length validPart + 1) '0'+ oversized = validPart <> BS.pack (map (fromIntegral . fromEnum) padding)+ JI.decodeUberTraceId oversized `shouldBe` Nothing++ describe "trace context extraction" $ do+ it "extracts SpanContext from uber-trace-id (sampled)" $ do+ let headers =+ textMapFromList+ [("uber-trace-id", "80f198ee56343ba864fe8b2a57d3eff7:e457b5a2e4d86bd1:0:1")]+ ctx' <- extractor jaegerTraceContextPropagator headers empty+ case lookupSpan ctx' of+ Nothing -> expectationFailure "expected span in context"+ Just span' -> do+ sc <- getSpanContext span'+ traceId sc `shouldBe` expectedTraceId+ spanId sc `shouldBe` expectedSpanId+ isRemote sc `shouldBe` True+ isSampled (traceFlags sc) `shouldBe` True++ it "extracts SpanContext from uber-trace-id (unsampled)" $ do+ let headers =+ textMapFromList+ [("uber-trace-id", "80f198ee56343ba864fe8b2a57d3eff7:e457b5a2e4d86bd1:0:0")]+ ctx' <- extractor jaegerTraceContextPropagator headers empty+ case lookupSpan ctx' of+ Nothing -> expectationFailure "expected span in context"+ Just span' -> do+ sc <- getSpanContext span'+ isSampled (traceFlags sc) `shouldBe` False++ it "debug flag implies sampled" $ do+ let headers =+ textMapFromList+ [("uber-trace-id", "80f198ee56343ba864fe8b2a57d3eff7:e457b5a2e4d86bd1:0:2")]+ ctx' <- extractor jaegerTraceContextPropagator headers empty+ case lookupSpan ctx' of+ Nothing -> expectationFailure "expected span in context"+ Just span' -> do+ sc <- getSpanContext span'+ isSampled (traceFlags sc) `shouldBe` True++ it "leaves context unchanged when header is missing" $ do+ ctx' <- extractor jaegerTraceContextPropagator emptyTextMap empty+ lookupSpan ctx' `shouldSatisfy` isNothing++ it "leaves context unchanged for malformed header" $ do+ let headers = textMapFromList [("uber-trace-id", "not-a-valid-header")]+ ctx' <- extractor jaegerTraceContextPropagator headers empty+ lookupSpan ctx' `shouldSatisfy` isNothing++ -- HTTP header names are case-insensitive (RFC 9110)+ it "header name is case-insensitive" $ do+ let headers =+ textMapFromList+ [("Uber-Trace-Id", "80f198ee56343ba864fe8b2a57d3eff7:e457b5a2e4d86bd1:0:1")]+ ctx' <- extractor jaegerTraceContextPropagator headers empty+ case lookupSpan ctx' of+ Nothing -> expectationFailure "expected span in context"+ Just span' -> do+ sc <- getSpanContext span'+ traceId sc `shouldBe` expectedTraceId++ describe "trace context injection" $ do+ it "injects uber-trace-id with sampled flag" $ do+ let ctx = insertSpan (wrapSpanContext sampledSpanContext) empty+ hs <- injector jaegerTraceContextPropagator ctx emptyTextMap+ case textMapLookup "uber-trace-id" hs of+ Nothing -> expectationFailure "expected uber-trace-id header"+ Just v -> do+ let parts = T.splitOn ":" v+ length parts `shouldBe` 4+ parts !! 0 `shouldBe` traceIdHex+ parts !! 1 `shouldBe` spanIdHex+ parts !! 2 `shouldBe` "0"+ parts !! 3 `shouldBe` "1"++ it "injects uber-trace-id with unsampled flag" $ do+ let ctx = insertSpan (wrapSpanContext unsampledSpanContext) empty+ hs <- injector jaegerTraceContextPropagator ctx emptyTextMap+ case textMapLookup "uber-trace-id" hs of+ Nothing -> expectationFailure "expected uber-trace-id header"+ Just v -> do+ let parts = T.splitOn ":" v+ parts !! 3 `shouldBe` "0"++ it "does not inject when no span in context" $ do+ hs <- injector jaegerTraceContextPropagator empty emptyTextMap+ textMapLookup "uber-trace-id" hs `shouldSatisfy` isNothing++ describe "round-trip" $ do+ it "extract after inject preserves trace and span IDs" $ do+ let ctx = insertSpan (wrapSpanContext sampledSpanContext) empty+ hs <- injector jaegerTraceContextPropagator ctx emptyTextMap+ ctx' <- extractor jaegerTraceContextPropagator hs empty+ case lookupSpan ctx' of+ Nothing -> expectationFailure "expected span in context after round-trip"+ Just span' -> do+ sc <- getSpanContext span'+ traceId sc `shouldBe` expectedTraceId+ spanId sc `shouldBe` expectedSpanId+ isSampled (traceFlags sc) `shouldBe` True++ it "round-trip preserves unsampled flag" $ do+ let ctx = insertSpan (wrapSpanContext unsampledSpanContext) empty+ hs <- injector jaegerTraceContextPropagator ctx emptyTextMap+ ctx' <- extractor jaegerTraceContextPropagator hs empty+ case lookupSpan ctx' of+ Nothing -> expectationFailure "expected span in context"+ Just span' -> do+ sc <- getSpanContext span'+ isSampled (traceFlags sc) `shouldBe` False++ -- Jaeger baggage as uberctx-{key} headers+ -- https://www.jaegertracing.io/docs/1.21/client-libraries/#propagation-format+ describe "baggage propagation" $ do+ it "extracts baggage from uberctx-* headers" $ do+ let headers =+ textMapFromList+ [ ("uber-trace-id", "80f198ee56343ba864fe8b2a57d3eff7:e457b5a2e4d86bd1:0:1")+ , ("uberctx-user-id", "42")+ , ("uberctx-session", "abc123")+ ]+ ctx' <- extractor jaegerPropagator headers empty+ case lookupBaggage ctx' of+ Nothing -> expectationFailure "expected baggage in context"+ Just bag -> do+ let vals = H.toList (Baggage.values bag)+ length vals `shouldSatisfy` (>= 2)++ it "injects baggage as uberctx-* headers" $ do+ case Baggage.decodeBaggageHeader "user-id=42,session=abc123" of+ Left err -> expectationFailure $ "baggage setup failed: " ++ err+ Right bag -> do+ let ctx =+ insertSpan (wrapSpanContext sampledSpanContext) $+ insertBaggage bag empty+ hs <- injector jaegerPropagator ctx emptyTextMap+ textMapLookup "uberctx-user-id" hs `shouldBe` Just "42"+ textMapLookup "uberctx-session" hs `shouldBe` Just "abc123"++ it "does not inject baggage headers when no baggage in context" $ do+ let ctx = insertSpan (wrapSpanContext sampledSpanContext) empty+ hs <- injector jaegerPropagator ctx emptyTextMap+ let baggageHeaders = filter (T.isPrefixOf "uberctx-") $ map fst $ textMapToListImpl hs+ baggageHeaders `shouldBe` []++ describe "propagatorFields" $ do+ it "trace context propagator declares uber-trace-id" $ do+ propagatorFields jaegerTraceContextPropagator `shouldBe` ["uber-trace-id"]+++-- Helpers --------------------------------------------------------------------++textMapToListImpl :: TextMap -> [(T.Text, T.Text)]+textMapToListImpl tm =+ map (\k -> (k, maybe "" id (textMapLookup k tm))) (textMapKeys tm)+++traceIdHex :: T.Text+traceIdHex = "80f198ee56343ba864fe8b2a57d3eff7"+++spanIdHex :: T.Text+spanIdHex = "e457b5a2e4d86bd1"+++expectedTraceId :: TraceId+expectedTraceId =+ case baseEncodedToTraceId Base16 (TE.encodeUtf8 traceIdHex) of+ Right t -> t+ Left e -> error ("expectedTraceId: " ++ e)+++-- 64-bit trace ID "64fe8b2a57d3eff7" → zero-padded to 128-bit+expectedTraceId64 :: TraceId+expectedTraceId64 =+ case baseEncodedToTraceId Base16 "000000000000000064fe8b2a57d3eff7" of+ Right t -> t+ Left e -> error ("expectedTraceId64: " ++ e)+++expectedSpanId :: SpanId+expectedSpanId =+ case baseEncodedToSpanId Base16 (TE.encodeUtf8 spanIdHex) of+ Right s -> s+ Left e -> error ("expectedSpanId: " ++ e)+++sampledSpanContext :: SpanContext+sampledSpanContext =+ SpanContext+ { traceId = expectedTraceId+ , spanId = expectedSpanId+ , isRemote = False+ , traceFlags = TraceFlags 1+ , traceState = TraceState []+ }+++unsampledSpanContext :: SpanContext+unsampledSpanContext =+ SpanContext+ { traceId = expectedTraceId+ , spanId = expectedSpanId+ , isRemote = False+ , traceFlags = TraceFlags 0+ , traceState = TraceState []+ }
+ test/Spec.hs view
@@ -0,0 +1,2 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}+