diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/hs-opentelemetry-propagator-w3c.cabal b/hs-opentelemetry-propagator-w3c.cabal --- a/hs-opentelemetry-propagator-w3c.cabal +++ b/hs-opentelemetry-propagator-w3c.cabal @@ -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 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 diff --git a/src/OpenTelemetry/Propagator/W3CBaggage.hs b/src/OpenTelemetry/Propagator/W3CBaggage.hs --- a/src/OpenTelemetry/Propagator/W3CBaggage.hs +++ b/src/OpenTelemetry/Propagator/W3CBaggage.hs @@ -20,7 +20,7 @@ encodeBaggage = Baggage.encodeBaggageHeader -w3cBaggagePropagator :: Propagator Context RequestHeaders ResponseHeaders +w3cBaggagePropagator :: Propagator Context RequestHeaders RequestHeaders w3cBaggagePropagator = Propagator {..} where propagatorNames = ["baggage"] diff --git a/src/OpenTelemetry/Propagator/W3CTraceContext.hs b/src/OpenTelemetry/Propagator/W3CTraceContext.hs --- a/src/OpenTelemetry/Propagator/W3CTraceContext.hs +++ b/src/OpenTelemetry/Propagator/W3CTraceContext.hs @@ -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"] diff --git a/test/OpenTelemetry/Propagator/W3CIntegrationSpec.hs b/test/OpenTelemetry/Propagator/W3CIntegrationSpec.hs new file mode 100644 --- /dev/null +++ b/test/OpenTelemetry/Propagator/W3CIntegrationSpec.hs @@ -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 diff --git a/test/OpenTelemetry/Propagator/W3CMultiHeaderSpec.hs b/test/OpenTelemetry/Propagator/W3CMultiHeaderSpec.hs new file mode 100644 --- /dev/null +++ b/test/OpenTelemetry/Propagator/W3CMultiHeaderSpec.hs @@ -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" diff --git a/test/OpenTelemetry/Propagator/W3CTraceContextSpec.hs b/test/OpenTelemetry/Propagator/W3CTraceContextSpec.hs new file mode 100644 --- /dev/null +++ b/test/OpenTelemetry/Propagator/W3CTraceContextSpec.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} +