hs-opentelemetry-propagator-w3c 0.0.1.4 → 0.1.0.0
raw patch · 8 files changed
+761/−10 lines, 8 filesdep +QuickCheckdep +hs-opentelemetry-propagator-w3cdep +hspecdep ~hs-opentelemetry-api
Dependencies added: QuickCheck, hs-opentelemetry-propagator-w3c, hspec, hspec-discover, text
Dependency ranges changed: hs-opentelemetry-api
Files
- ChangeLog.md +25/−0
- hs-opentelemetry-propagator-w3c.cabal +27/−3
- src/OpenTelemetry/Propagator/W3CBaggage.hs +1/−1
- src/OpenTelemetry/Propagator/W3CTraceContext.hs +187/−6
- test/OpenTelemetry/Propagator/W3CIntegrationSpec.hs +179/−0
- test/OpenTelemetry/Propagator/W3CMultiHeaderSpec.hs +173/−0
- test/OpenTelemetry/Propagator/W3CTraceContextSpec.hs +167/−0
- test/Spec.hs +2/−0
ChangeLog.md view
@@ -1,5 +1,30 @@ # Changelog for hs-opentelemetry-propagator-w3c +## Unreleased++## 0.1.0.0++### Added+- Complete W3C tracestate header parsing and encoding support+- `tracestateParser` for parsing W3C tracestate headers according to specification+- `encodeTraceState` function for serializing TraceState to W3C format+- `encodeTraceStateFull` for serializing complete TraceState without HTTP header limits+- `encodeTraceStateMultiple` for splitting TraceState into multiple headers with size constraints+- `decodeTraceStateMultiple` for combining multiple tracestate headers per RFC7230+- Proper validation of tracestate keys and values per W3C spec+- Support for up to 32 tracestate entries as per specification+- Multi-tenant key format support (`tenant@vendor`)+- Automatic removal of oversized entries (>128 chars) as per W3C truncation guidance+- RFC7230-compliant header field combining with comma separation+- Comprehensive test coverage for tracestate functionality++### Changed+- `encodeSpanContext` now includes tracestate in returned tuple+- `decodeSpanContext` now properly decodes and validates tracestate headers++### Dependencies+- Added `text` dependency for tracestate text processing+ ## 0.0.1.4 - Support newer dependencies
hs-opentelemetry-propagator-w3c.cabal view
@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.36.0.+-- This file has been generated from package.yaml by hpack version 0.37.0. -- -- see: https://github.com/sol/hpack name: hs-opentelemetry-propagator-w3c-version: 0.0.1.4+version: 0.1.0.0 synopsis: Trace propagation via HTTP headers following the w3c tracestate spec. description: Please see the README on GitHub at <https://github.com/iand675/hs-opentelemetry/tree/main/propagators/w3c#readme> category: OpenTelemetry, Tracing, Web@@ -38,6 +38,30 @@ attoparsec , base >=4.7 && <5 , bytestring- , hs-opentelemetry-api ==0.2.*+ , hs-opentelemetry-api ==0.3.* , http-types+ , text+ default-language: Haskell2010++test-suite hs-opentelemetry-propagator-w3c-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ OpenTelemetry.Propagator.W3CIntegrationSpec+ OpenTelemetry.Propagator.W3CMultiHeaderSpec+ OpenTelemetry.Propagator.W3CTraceContextSpec+ Paths_hs_opentelemetry_propagator_w3c+ hs-source-dirs:+ test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ QuickCheck+ , attoparsec+ , base >=4.7 && <5+ , bytestring+ , hs-opentelemetry-api+ , hs-opentelemetry-propagator-w3c+ , hspec+ , hspec-discover+ , text default-language: Haskell2010
src/OpenTelemetry/Propagator/W3CBaggage.hs view
@@ -20,7 +20,7 @@ encodeBaggage = Baggage.encodeBaggageHeader -w3cBaggagePropagator :: Propagator Context RequestHeaders ResponseHeaders+w3cBaggagePropagator :: Propagator Context RequestHeaders RequestHeaders w3cBaggagePropagator = Propagator {..} where propagatorNames = ["baggage"]
src/OpenTelemetry/Propagator/W3CTraceContext.hs view
@@ -31,17 +31,25 @@ import Data.Attoparsec.ByteString.Char8 ( Parser,+ char,+ endOfInput, hexadecimal, parseOnly,+ sepBy,+ skipSpace, string, takeWhile,+ takeWhile1, ) import Data.ByteString (ByteString) import qualified Data.ByteString.Builder as B+import qualified Data.ByteString.Char8 as C8 import qualified Data.ByteString.Lazy as L import Data.Char (isHexDigit)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE import Data.Word (Word8)-import Network.HTTP.Types (RequestHeaders, ResponseHeaders)+import Network.HTTP.Types (RequestHeaders) import qualified OpenTelemetry.Context as Ctxt import OpenTelemetry.Propagator (Propagator (..)) import OpenTelemetry.Trace.Core (@@ -54,7 +62,7 @@ wrapSpanContext, ) import OpenTelemetry.Trace.Id (Base (..), SpanId, TraceId, baseEncodedToSpanId, baseEncodedToTraceId, spanIdBaseEncodedBuilder, traceIdBaseEncodedBuilder)-import OpenTelemetry.Trace.TraceState (TraceState, empty)+import OpenTelemetry.Trace.TraceState (Key (..), TraceState, Value (..), empty, fromList, toList) import Prelude hiding (takeWhile) @@ -102,7 +110,9 @@ Right ok -> Just ok decodeTracestateHeader :: ByteString -> TraceState- decodeTracestateHeader _ = empty+ decodeTracestateHeader ts = case parseOnly tracestateParser ts of+ Left _ -> empty+ Right ok -> ok traceparentParser :: Parser TraceParent@@ -124,6 +134,178 @@ pure $ TraceParent {..} +{- | Parser for W3C tracestate header format+Format: OWS list-member *( OWS "," OWS list-member ) OWS+See: https://www.w3.org/TR/trace-context/#tracestate-header+-}+tracestateParser :: Parser TraceState+tracestateParser = do+ skipSpace+ pairs <- tracestateEntry `sepBy` (skipSpace >> char ',' >> skipSpace)+ skipSpace+ endOfInput+ -- Limit to 32 entries as per spec, take first 32 if more+ let limitedPairs = take 32 pairs+ pure $ fromList [(Key k, Value v) | (k, v) <- limitedPairs]+ where+ -- Parse a single key=value entry (list-member)+ tracestateEntry = do+ key <- tracestateKey+ _ <- char '='+ value <- tracestateValue+ pure (key, value)++ -- Parse tracestate key according to W3C spec+ -- key = simple-key / multi-tenant-key+ -- simple-key = lcalpha 0*255( lcalpha / DIGIT / "_" / "-"/ "*" / "/" )+ -- multi-tenant-key = tenant-id "@" system-id+ tracestateKey = do+ keyBytes <- takeWhile1 isTracestateKeyChar+ let keyText = TE.decodeUtf8 keyBytes+ -- Validate key format and length (max 256 chars)+ if T.length keyText <= 256 && isValidTracestateKey keyText+ then pure keyText+ else fail "Invalid tracestate key"++ -- Parse tracestate value according to W3C spec+ -- value = 0*255(chr) nblk-chr+ -- chr = %x20 / %x21-2B / %x2D-3C / %x3E-7E+ -- nblk-chr = %x21-2B / %x2D-3C / %x3E-7E+ tracestateValue = do+ valueBytes <- takeWhile1 isTracestateValueChar+ let valueText = T.stripEnd $ TE.decodeUtf8 valueBytes -- Strip trailing whitespace+ -- Validate value length (max 256 chars)+ if T.length valueText <= 256 && not (T.null valueText)+ then pure valueText+ else fail "Invalid tracestate value"++ -- Valid characters for tracestate keys+ isTracestateKeyChar c =+ (c >= 'a' && c <= 'z')+ || (c >= '0' && c <= '9')+ || c == '_'+ || c == '-'+ || c == '*'+ || c == '/'+ || c == '@'++ -- Valid characters for tracestate values (chr)+ -- %x20 / %x21-2B / %x2D-3C / %x3E-7E (excludes comma and equals)+ isTracestateValueChar c =+ c == ' ' || (c >= '!' && c <= '+') || (c >= '-' && c <= '<') || (c >= '>' && c <= '~')++ -- Validate tracestate key format+ isValidTracestateKey key =+ case T.uncons key of+ Nothing -> False+ Just (firstChar, rest) ->+ -- Must start with lowercase letter or digit+ (firstChar >= 'a' && firstChar <= 'z' || firstChar >= '0' && firstChar <= '9')+ &&+ -- Rest must be valid key characters+ T.all+ ( \c ->+ (c >= 'a' && c <= 'z')+ || (c >= '0' && c <= '9')+ || c == '_'+ || c == '-'+ || c == '*'+ || c == '/'+ || c == '@'+ )+ rest+++-- | Encode TraceState to W3C tracestate header format+encodeTraceState :: TraceState -> ByteString+encodeTraceState ts =+ let pairs = toList ts+ -- Limit to 32 entries as per spec+ limitedPairs = take 32 pairs+ encodedPairs = map (\(Key k, Value v) -> TE.encodeUtf8 k <> "=" <> TE.encodeUtf8 v) limitedPairs+ in C8.intercalate "," encodedPairs+++{- | Encode TraceState for non-HTTP contexts (like OTLP binary format).++ This function preserves all tracestate entries without applying HTTP header+ constraints like the 32-entry limit. Use this for binary protocols where+ the full tracestate should be preserved.++ @since 0.0.1.5+-}+encodeTraceStateFull :: TraceState -> ByteString+encodeTraceStateFull ts =+ let pairs = toList ts+ encodedPairs = map (\(Key k, Value v) -> TE.encodeUtf8 k <> "=" <> TE.encodeUtf8 v) pairs+ in C8.intercalate "," encodedPairs+++{- | Split a TraceState into multiple tracestate header values based on size constraints.++ This function respects the W3C recommendation that vendors should propagate at least+ 512 characters, while following RFC7230 rules for splitting header fields.++ When splitting is needed:+ - Entries larger than 128 characters are removed first (as per W3C spec)+ - Remaining entries are split to keep each header under the size limit+ - Entry order is preserved within each header++ @since 0.0.1.5+-}+encodeTraceStateMultiple+ :: Int+ -- ^ Maximum size per header (e.g., 512 for minimum recommended size)+ -> TraceState+ -> [ByteString]+ -- ^ List of tracestate header values+encodeTraceStateMultiple maxSize ts =+ let pairs = toList ts+ -- Limit to 32 entries as per spec, then filter out oversized entries+ limitedPairs = take 32 pairs+ filteredPairs = filter (\(Key k, Value v) -> T.length k + T.length v + 1 <= 128) limitedPairs+ encodedPairs = map (\(Key k, Value v) -> TE.encodeUtf8 k <> "=" <> TE.encodeUtf8 v) filteredPairs+ in splitIntoHeaders maxSize encodedPairs+ where+ splitIntoHeaders :: Int -> [ByteString] -> [ByteString]+ splitIntoHeaders _ [] = []+ splitIntoHeaders limit entries =+ let (currentHeader, remaining) = buildHeader limit entries []+ in if C8.null currentHeader+ then []+ else currentHeader : splitIntoHeaders limit remaining++ buildHeader :: Int -> [ByteString] -> [ByteString] -> (ByteString, [ByteString])+ buildHeader _ [] acc = (C8.intercalate "," (reverse acc), [])+ buildHeader limit (entry : rest) acc =+ let currentSize = if null acc then 0 else sum (map C8.length acc) + length acc - 1 -- account for commas+ newSize = currentSize + C8.length entry + if null acc then 0 else 1+ in if newSize <= limit || null acc -- Always include at least one entry+ then buildHeader limit rest (entry : acc)+ else (C8.intercalate "," (reverse acc), entry : rest)+++{- | Combine multiple tracestate header values into a single TraceState.++ This function implements RFC7230 Section 3.2.2 rules for combining multiple+ header fields with the same name. Header values are combined with commas+ in the order provided.++ Invalid entries are skipped with a fallback to empty TraceState on complete failure.++ @since 0.0.1.5+-}+decodeTraceStateMultiple :: [ByteString] -> TraceState+decodeTraceStateMultiple headers =+ let nonEmptyHeaders = filter (not . C8.all (\c -> c == ' ' || c == '\t')) headers+ combinedHeader = C8.intercalate "," nonEmptyHeaders+ in if C8.null combinedHeader+ then empty+ else case parseOnly tracestateParser combinedHeader of+ Right ts -> ts+ Left _ -> empty -- Fallback to empty on parse failure++ {- | Encoded the given 'Span' into a @traceparent@, @tracestate@ tuple. @since 0.0.1.0@@ -131,8 +313,7 @@ encodeSpanContext :: Span -> IO (ByteString, ByteString) encodeSpanContext s = do ctxt <- getSpanContext s- -- TODO tracestate- pure (L.toStrict $ B.toLazyByteString $ traceparentHeader ctxt, "")+ pure (L.toStrict $ B.toLazyByteString $ traceparentHeader ctxt, encodeTraceState (traceState ctxt)) where traceparentHeader SpanContext {..} = -- version@@ -149,7 +330,7 @@ @since 0.0.1.0 -}-w3cTraceContextPropagator :: Propagator Ctxt.Context RequestHeaders ResponseHeaders+w3cTraceContextPropagator :: Propagator Ctxt.Context RequestHeaders RequestHeaders w3cTraceContextPropagator = Propagator {..} where propagatorNames = ["tracecontext"]
+ test/OpenTelemetry/Propagator/W3CIntegrationSpec.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module OpenTelemetry.Propagator.W3CIntegrationSpec (spec) where++import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as C8+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import OpenTelemetry.Common (TraceFlags (..))+import OpenTelemetry.Propagator.W3CTraceContext+import OpenTelemetry.Trace.Core+import OpenTelemetry.Trace.Id+import OpenTelemetry.Trace.TraceState (Key (..), Value (..), empty, fromList, insert, toList)+import Test.Hspec+++spec :: Spec+spec = describe "W3C TraceContext Integration" $ do+ describe "decodeSpanContext" $ do+ it "decodes traceparent and empty tracestate" $ do+ let traceparent = Just "00-0af7651916cd43dd8448eb211c80319c-b7ad6b7169203331-01"+ tracestate = Nothing+ result = decodeSpanContext traceparent tracestate+ case result of+ Just spanCtx -> do+ OpenTelemetry.Trace.Core.traceFlags spanCtx `shouldBe` TraceFlags 1+ traceState spanCtx `shouldBe` empty+ Nothing -> expectationFailure "Failed to decode span context"++ it "decodes traceparent and tracestate with single entry" $ do+ let traceparent = Just "00-0af7651916cd43dd8448eb211c80319c-b7ad6b7169203331-01"+ tracestate = Just "vendor1=value1"+ result = decodeSpanContext traceparent tracestate+ case result of+ Just spanCtx -> do+ OpenTelemetry.Trace.Core.traceFlags spanCtx `shouldBe` TraceFlags 1+ traceState spanCtx `shouldBe` insert (Key "vendor1") (Value "value1") empty+ Nothing -> expectationFailure "Failed to decode span context"++ it "decodes traceparent and tracestate with multiple entries" $ do+ let traceparent = Just "00-0af7651916cd43dd8448eb211c80319c-b7ad6b7169203331-01"+ tracestate = Just "vendor1=value1,vendor2=value2,vendor3=value3"+ result = decodeSpanContext traceparent tracestate+ case result of+ Just spanCtx -> do+ OpenTelemetry.Trace.Core.traceFlags spanCtx `shouldBe` TraceFlags 1+ let decodedPairs = toList (traceState spanCtx)+ decodedPairs `shouldContain` [(Key "vendor1", Value "value1")]+ decodedPairs `shouldContain` [(Key "vendor2", Value "value2")]+ decodedPairs `shouldContain` [(Key "vendor3", Value "value3")]+ length decodedPairs `shouldBe` 3+ Nothing -> expectationFailure "Failed to decode span context"++ it "handles invalid tracestate gracefully" $ do+ let traceparent = Just "00-0af7651916cd43dd8448eb211c80319c-b7ad6b7169203331-01"+ tracestate = Just "INVALID$KEY=value1" -- Invalid key format+ result = decodeSpanContext traceparent tracestate+ case result of+ Just spanCtx -> do+ OpenTelemetry.Trace.Core.traceFlags spanCtx `shouldBe` TraceFlags 1+ traceState spanCtx `shouldBe` empty -- Should fall back to empty+ Nothing -> expectationFailure "Failed to decode span context"++ it "returns Nothing for invalid traceparent" $ do+ let traceparent = Just "invalid-traceparent"+ tracestate = Just "vendor1=value1"+ result = decodeSpanContext traceparent tracestate+ result `shouldBe` Nothing++ it "returns Nothing for missing traceparent" $ do+ let traceparent = Nothing+ tracestate = Just "vendor1=value1"+ result = decodeSpanContext traceparent tracestate+ result `shouldBe` Nothing++ describe "encodeTraceState integration" $ do+ it "encodes complex tracestate correctly" $ do+ let complexState =+ fromList+ [ (Key "tenant@vendor", Value "complex-value_with*chars")+ , (Key "simple", Value "value")+ , (Key "numeric123", Value "123-456")+ ]+ encoded = encodeTraceState complexState+ -- Verify it can be round-tripped+ let traceparent = Just "00-0af7651916cd43dd8448eb211c80319c-b7ad6b7169203331-01"+ result = decodeSpanContext traceparent (Just encoded)+ case result of+ Just spanCtx -> do+ let decodedState = traceState spanCtx+ decodedState `shouldBe` complexState+ Nothing -> expectationFailure "Failed to round-trip complex tracestate"++ it "handles empty tracestate in round-trip" $ do+ let encoded = encodeTraceState empty+ encoded `shouldBe` ""+ let traceparent = Just "00-0af7651916cd43dd8448eb211c80319c-b7ad6b7169203331-01"+ result = decodeSpanContext traceparent (if encoded == "" then Nothing else Just encoded)+ case result of+ Just spanCtx -> traceState spanCtx `shouldBe` empty+ Nothing -> expectationFailure "Failed to handle empty tracestate"++ describe "W3C specification compliance" $ do+ it "respects 32 entry limit in parsing" $ do+ let entries = ["key" ++ show i ++ "=value" ++ show i | i <- [1 .. 40]]+ longTracestate = C8.intercalate "," $ map C8.pack entries+ traceparent = Just "00-0af7651916cd43dd8448eb211c80319c-b7ad6b7169203331-01"+ result = decodeSpanContext traceparent (Just longTracestate)+ case result of+ Just spanCtx -> do+ let stateEntries = traceState spanCtx+ length (toList stateEntries) `shouldBe` 32+ Nothing -> expectationFailure "Failed to parse long tracestate"++ it "validates key format according to spec" $ do+ let testCases =+ [ ("validkey", True)+ , ("valid123", True)+ , ("valid_key", True)+ , ("valid-key", True)+ , ("valid*key", True)+ , ("valid/key", True)+ , ("tenant@vendor", True)+ , ("123numeric", True)+ , ("INVALIDKEY", False) -- Must start with lowercase+ , ("invalid$key", False) -- Invalid character+ , ("", False) -- Empty key+ ]+ mapM_+ ( \(key, shouldSucceed) -> do+ let tracestate = C8.pack $ T.unpack key ++ "=value"+ traceparent = Just "00-0af7651916cd43dd8448eb211c80319c-b7ad6b7169203331-01"+ result = decodeSpanContext traceparent (Just tracestate)+ if shouldSucceed+ then+ result+ `shouldSatisfy` ( \case+ Just spanCtx -> not $ null $ toList $ traceState spanCtx+ Nothing -> False+ )+ else+ result+ `shouldSatisfy` ( \case+ Just spanCtx -> null $ toList $ traceState spanCtx+ Nothing -> True+ )+ )+ testCases++ it "validates value format according to spec" $ do+ let testCases =+ [ ("validvalue", True)+ , ("valid value with spaces", True)+ , ("valid-value_with*special/chars", True)+ , ("valid!value#with$symbols%", True)+ , ("value,with,comma", False) -- Comma not allowed+ , ("value=with=equals", False) -- Equals not allowed in continuation+ ]+ mapM_+ ( \(value, shouldSucceed) -> do+ let tracestate = C8.pack $ "validkey=" ++ T.unpack value+ traceparent = Just "00-0af7651916cd43dd8448eb211c80319c-b7ad6b7169203331-01"+ result = decodeSpanContext traceparent (Just tracestate)+ if shouldSucceed+ then+ result+ `shouldSatisfy` ( \case+ Just spanCtx -> not $ null $ toList $ traceState spanCtx+ Nothing -> False+ )+ else+ result+ `shouldSatisfy` ( \case+ Just spanCtx -> null $ toList $ traceState spanCtx+ Nothing -> True+ )+ )+ testCases
+ test/OpenTelemetry/Propagator/W3CMultiHeaderSpec.hs view
@@ -0,0 +1,173 @@+{-# LANGUAGE OverloadedStrings #-}++module OpenTelemetry.Propagator.W3CMultiHeaderSpec (spec) where++import qualified Data.ByteString.Char8 as C8+import Data.List (intercalate)+import qualified Data.Text as T+import OpenTelemetry.Propagator.W3CTraceContext+import OpenTelemetry.Trace.TraceState (Key (..), Value (..), empty, fromList, toList)+import Test.Hspec+++spec :: Spec+spec = describe "W3C TraceContext Multi-Header Support" $ do+ describe "encodeTraceStateMultiple" $ do+ it "returns single header for small tracestate" $ do+ let ts = fromList [(Key "vendor1", Value "value1"), (Key "vendor2", Value "value2")]+ result = encodeTraceStateMultiple 512 ts+ result `shouldBe` ["vendor1=value1,vendor2=value2"]++ it "splits into multiple headers when size limit exceeded" $ do+ let mediumValue = T.replicate 50 "x" -- Use smaller values that won't be filtered+ ts =+ fromList+ [ (Key "vendor1", Value mediumValue)+ , (Key "vendor2", Value mediumValue)+ , (Key "vendor3", Value mediumValue)+ , (Key "vendor4", Value mediumValue)+ ]+ result = encodeTraceStateMultiple 150 ts -- Small limit to force splitting+ length result `shouldSatisfy` (> 1)+ -- Each header should be under the size limit+ all (\h -> C8.length h <= 150) result `shouldBe` True++ it "removes entries larger than 128 characters" $ do+ let longValue = T.replicate 200 "x" -- This entry will be > 128 chars total+ shortValue = "short"+ ts =+ fromList+ [ (Key "long", Value longValue)+ , (Key "vendor1", Value shortValue)+ , (Key "vendor2", Value shortValue)+ ]+ result = encodeTraceStateMultiple 512 ts+ combinedResult = C8.intercalate "," result+ -- The long entry should be filtered out+ combinedResult `shouldNotSatisfy` C8.isInfixOf "long="+ combinedResult `shouldSatisfy` C8.isInfixOf "vendor1=short"+ combinedResult `shouldSatisfy` C8.isInfixOf "vendor2=short"++ it "respects 32 entry limit before splitting" $ do+ let pairs = [(Key (T.pack $ "key" ++ show i), Value (T.pack $ "val" ++ show i)) | i <- [1 .. 40]]+ ts = fromList pairs+ result = encodeTraceStateMultiple 512 ts+ combinedResult = C8.intercalate "," result+ entryCount = length $ filter (== '=') $ C8.unpack combinedResult+ entryCount `shouldBe` 32++ it "returns empty list for empty tracestate" $ do+ let result = encodeTraceStateMultiple 512 empty+ result `shouldBe` []++ it "handles single very large header correctly" $ do+ let pairs = [(Key (T.pack $ "k" ++ show i), Value (T.pack $ "v" ++ show i)) | i <- [1 .. 20]]+ ts = fromList pairs+ result = encodeTraceStateMultiple 50 ts -- Very small limit+ length result `shouldSatisfy` (> 1)+ -- Should not exceed the limit+ all (\h -> C8.length h <= 50) result `shouldBe` True++ describe "decodeTraceStateMultiple" $ do+ it "combines single header correctly" $ do+ let headers = ["vendor1=value1,vendor2=value2"]+ result = decodeTraceStateMultiple headers+ pairs = toList result+ pairs `shouldContain` [(Key "vendor1", Value "value1")]+ pairs `shouldContain` [(Key "vendor2", Value "value2")]++ it "combines multiple headers in order" $ do+ let headers = ["vendor1=value1,vendor2=value2", "vendor3=value3,vendor4=value4"]+ result = decodeTraceStateMultiple headers+ pairs = toList result+ length pairs `shouldBe` 4+ pairs `shouldContain` [(Key "vendor1", Value "value1")]+ pairs `shouldContain` [(Key "vendor2", Value "value2")]+ pairs `shouldContain` [(Key "vendor3", Value "value3")]+ pairs `shouldContain` [(Key "vendor4", Value "value4")]++ it "handles empty headers gracefully" $ do+ let headers = ["vendor1=value1", "", "vendor2=value2"]+ result = decodeTraceStateMultiple headers+ pairs = toList result+ pairs `shouldContain` [(Key "vendor1", Value "value1")]+ pairs `shouldContain` [(Key "vendor2", Value "value2")]++ it "returns empty tracestate for invalid headers" $ do+ let headers = ["invalid$key=value", "another=bad,value"]+ result = decodeTraceStateMultiple headers+ result `shouldBe` empty++ it "returns empty tracestate for empty header list" $ do+ let result = decodeTraceStateMultiple []+ result `shouldBe` empty++ it "handles whitespace-only headers" $ do+ let headers = ["vendor1=value1", " ", "vendor2=value2"]+ result = decodeTraceStateMultiple headers+ pairs = toList result+ pairs `shouldContain` [(Key "vendor1", Value "value1")]+ pairs `shouldContain` [(Key "vendor2", Value "value2")]++ describe "round-trip multi-header property" $ do+ it "round-trips through multiple headers" $ do+ let originalPairs =+ [ (Key "vendor1", Value "value1")+ , (Key "vendor2", Value "value2")+ , (Key "vendor3", Value "value3")+ ]+ ts = fromList originalPairs+ encoded = encodeTraceStateMultiple 512 ts+ decoded = decodeTraceStateMultiple encoded+ decodedPairs = toList decoded+ decodedPairs `shouldBe` originalPairs++ it "round-trips with size-constrained splitting" $ do+ let originalPairs =+ [ (Key "vendor1", Value "val1")+ , (Key "vendor2", Value "val2")+ , (Key "vendor3", Value "val3")+ , (Key "vendor4", Value "val4")+ ]+ ts = fromList originalPairs+ encoded = encodeTraceStateMultiple 25 ts -- Force splitting+ decoded = decodeTraceStateMultiple encoded+ decodedPairs = toList decoded+ -- Should contain all original entries (order may vary due to splitting)+ length decodedPairs `shouldBe` 4+ all (`elem` decodedPairs) originalPairs `shouldBe` True++ describe "RFC7230 compliance" $ do+ it "maintains header order when combining" $ do+ let headers = ["first=1", "second=2", "third=3"]+ result = decodeTraceStateMultiple headers+ -- The combined header should be processed in order+ result `shouldSatisfy` (/= empty)++ it "handles comma-separated values correctly" $ do+ let headers = ["a=1,b=2", "c=3,d=4"]+ result = decodeTraceStateMultiple headers+ pairs = toList result+ length pairs `shouldBe` 4+ pairs `shouldContain` [(Key "a", Value "1")]+ pairs `shouldContain` [(Key "b", Value "2")]+ pairs `shouldContain` [(Key "c", Value "3")]+ pairs `shouldContain` [(Key "d", Value "4")]++ describe "W3C specification compliance" $ do+ it "supports at least 512 character recommendation" $ do+ let longValuePairs = [(Key (T.pack $ "vendor" ++ show i), Value (T.pack $ replicate 30 'x')) | i <- [1 .. 10]]+ ts = fromList longValuePairs+ encoded = encodeTraceStateMultiple 512 ts+ totalSize = sum $ map C8.length encoded+ -- Should handle at least 512 characters worth of data+ totalSize `shouldSatisfy` (>= 300) -- Conservative check given filtering+ it "removes oversized entries as per spec" $ do+ let oversizedEntry = (Key "big", Value (T.replicate 200 "x"))+ normalEntry = (Key "small", Value "value")+ ts = fromList [oversizedEntry, normalEntry]+ encoded = encodeTraceStateMultiple 512 ts+ combined = C8.intercalate "," encoded+ -- Oversized entry should be filtered out+ combined `shouldNotSatisfy` C8.isInfixOf "big="+ combined `shouldSatisfy` C8.isInfixOf "small=value"
+ test/OpenTelemetry/Propagator/W3CTraceContextSpec.hs view
@@ -0,0 +1,167 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}++module OpenTelemetry.Propagator.W3CTraceContextSpec (spec) where++import Data.Attoparsec.ByteString (parseOnly)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as C8+import Data.Either (isLeft)+import qualified Data.Text as T+import OpenTelemetry.Propagator.W3CTraceContext+import OpenTelemetry.Trace.TraceState (Key (..), Value (..), empty, fromList, insert, toList)+import Test.Hspec+++spec :: Spec+spec = describe "W3C TraceContext TraceState" $ do+ describe "tracestateParser" $ do+ it "parses empty tracestate" $ do+ parseOnly tracestateParser "" `shouldBe` Right empty++ it "parses single key=value pair" $ do+ let result = parseOnly tracestateParser "vendor1=value1"+ result `shouldBe` Right (insert (Key "vendor1") (Value "value1") empty)++ it "parses multiple key=value pairs" $ do+ let result = parseOnly tracestateParser "vendor1=value1,vendor2=value2"+ case result of+ Right ts -> do+ let pairs = toList ts+ pairs `shouldContain` [(Key "vendor1", Value "value1")]+ pairs `shouldContain` [(Key "vendor2", Value "value2")]+ Left err -> expectationFailure $ "Parse failed: " ++ err++ it "parses key=value pairs with spaces" $ do+ let result = parseOnly tracestateParser " vendor1=value1 , vendor2=value2 "+ case result of+ Right ts -> do+ let pairs = toList ts+ pairs `shouldContain` [(Key "vendor1", Value "value1")]+ pairs `shouldContain` [(Key "vendor2", Value "value2")]+ Left err -> expectationFailure $ "Parse failed: " ++ err++ it "handles multi-tenant keys" $ do+ let result = parseOnly tracestateParser "tenant@vendor=value1"+ result `shouldBe` Right (insert (Key "tenant@vendor") (Value "value1") empty)++ it "handles special characters in keys" $ do+ let result = parseOnly tracestateParser "vendor-1_2*3/4@tenant=value1"+ result `shouldBe` Right (insert (Key "vendor-1_2*3/4@tenant") (Value "value1") empty)++ it "handles special characters in values" $ do+ let result = parseOnly tracestateParser "vendor1=value-with_special*chars/and@symbols"+ result `shouldBe` Right (insert (Key "vendor1") (Value "value-with_special*chars/and@symbols") empty)++ it "limits to 32 entries" $ do+ let pairs = [C8.pack $ "key" ++ show i ++ "=value" ++ show i | i <- [1 .. 40]]+ input = C8.intercalate "," pairs+ result = parseOnly tracestateParser input+ case result of+ Right ts -> length (toList ts) `shouldBe` 32+ Left err -> expectationFailure $ "Parse failed: " ++ err++ it "rejects invalid key starting with uppercase" $ do+ let result = parseOnly tracestateParser "VENDOR=value1"+ result `shouldSatisfy` isLeft++ it "rejects invalid key with invalid characters" $ do+ let result = parseOnly tracestateParser "vendor$=value1"+ result `shouldSatisfy` isLeft++ it "rejects keys that are too long" $ do+ let longKey = T.replicate 257 "a"+ input = C8.pack $ T.unpack longKey ++ "=value1"+ result = parseOnly tracestateParser input+ result `shouldSatisfy` isLeft++ it "rejects values that are too long" $ do+ let longValue = T.replicate 257 "a"+ input = C8.pack $ "vendor1=" ++ T.unpack longValue+ result = parseOnly tracestateParser input+ result `shouldSatisfy` isLeft++ it "rejects invalid value with comma" $ do+ let result = parseOnly tracestateParser "vendor1=value,with,comma"+ result `shouldSatisfy` isLeft++ it "rejects invalid value with equals" $ do+ let result = parseOnly tracestateParser "vendor1=value=with=equals"+ result `shouldSatisfy` isLeft++ describe "encodeTraceState" $ do+ it "encodes empty tracestate" $ do+ encodeTraceState empty `shouldBe` ""++ it "encodes single key=value pair" $ do+ let ts = insert (Key "vendor1") (Value "value1") empty+ encodeTraceState ts `shouldBe` "vendor1=value1"++ it "encodes multiple key=value pairs" $ do+ let ts = fromList [(Key "vendor1", Value "value1"), (Key "vendor2", Value "value2")]+ let encoded = encodeTraceState ts+ -- Order might vary, so check both possibilities+ encoded `shouldSatisfy` \s ->+ s == "vendor1=value1,vendor2=value2"+ || s == "vendor2=value2,vendor1=value1"++ it "limits to 32 entries when encoding" $ do+ let buildTS n acc+ | n > 40 = acc+ | otherwise =+ buildTS (n + 1) $+ insert+ (Key $ T.pack $ "key" ++ show n)+ (Value $ T.pack $ "value" ++ show n)+ acc+ ts = buildTS 1 empty+ encoded = encodeTraceState ts+ entryCount = length $ filter (== ',') $ C8.unpack encoded+ entryCount `shouldBe` 31 -- 32 entries = 31 commas+ it "handles special characters in encoding" $ do+ let ts = insert (Key "vendor-1_2*3/4@tenant") (Value "value-with_special*chars/and@symbols") empty+ encodeTraceState ts `shouldBe` "vendor-1_2*3/4@tenant=value-with_special*chars/and@symbols"++ describe "encodeTraceStateFull" $ do+ it "encodes empty tracestate" $ do+ encodeTraceStateFull empty `shouldBe` ""++ it "encodes single key=value pair" $ do+ let ts = insert (Key "vendor1") (Value "value1") empty+ encodeTraceStateFull ts `shouldBe` "vendor1=value1"++ it "preserves all entries beyond 32 limit" $ do+ let pairs = [(Key $ T.pack $ "key" ++ show i, Value $ T.pack $ "value" ++ show i) | i <- [1 .. 40]]+ ts = fromList pairs+ encoded = encodeTraceStateFull ts+ entryCount = length $ filter (== '=') $ C8.unpack encoded+ entryCount `shouldBe` 40 -- Should preserve all 40 entries+ it "does not filter oversized entries" $ do+ let longValue = T.replicate 200 "x" -- Much longer than 128 char limit+ ts = insert (Key "longentry") (Value longValue) empty+ encoded = encodeTraceStateFull ts+ encoded `shouldSatisfy` C8.isInfixOf "longentry="+ C8.length encoded `shouldSatisfy` (> 200)++ it "matches encodeTraceState for small tracestates" $ do+ let ts = fromList [(Key "vendor1", Value "value1"), (Key "vendor2", Value "value2")]+ encodeTraceStateFull ts `shouldBe` encodeTraceState ts++ describe "round-trip property" $ do+ it "round-trips simple valid tracestate" $ do+ let validPairs = [("vendor1", "value1"), ("vendor2", "value2")]+ ts = fromList [(Key $ T.pack k, Value $ T.pack v) | (k, v) <- validPairs]+ encoded = encodeTraceState ts+ parsed = parseOnly tracestateParser encoded+ case parsed of+ Right ts' -> toList ts' `shouldBe` toList ts+ Left err -> expectationFailure $ "Round-trip failed: " ++ err++ it "round-trips complex valid tracestate" $ do+ let validPairs = [("tenant@vendor", "complex-value_with*chars"), ("simple123", "value")]+ ts = fromList [(Key $ T.pack k, Value $ T.pack v) | (k, v) <- validPairs]+ encoded = encodeTraceState ts+ parsed = parseOnly tracestateParser encoded+ case parsed of+ Right ts' -> toList ts' `shouldBe` toList ts+ Left err -> expectationFailure $ "Round-trip failed: " ++ err
+ test/Spec.hs view
@@ -0,0 +1,2 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}+