diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,8 @@ # Changelog for instana-haskell-trace-sdk +## 0.10.0.0 +- Feature: Upgrade support for the W3C trace context specification to level 2. + ## 0.9.0.0 - Fix format of annotation span.data.http.header - it is now a JSON object instead of an array of arrays. - BREAKING: Rename confusingly named `Instana.SDK.addAnnotationAt` to `Instana.SDK.addJsonValueAt`, because it actually takes a JSON value. `Instana.SDK.addAnnotationAt` still exists, but takes an actual `Instana.SDK.Span.SpanData.Annotation` value as its argument now, see below. @@ -23,7 +26,7 @@ - Fix: Limit the number of list-members (key-value pairs) to 32 in the W3C trace context `tracestate` header. ## 0.7.0.0 -- Add support for W3C trace context. +- Add support for W3C trace context (level 1). - Fix: Interprete log levels provided via `INSTANA_LOG_LEVEL` and `INSTANA_LOG_LEVEL_STDOUT` case insensitive. ## 0.6.2.0 diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -64,7 +64,6 @@ * `README.md` (installation instructions/extra-deps) * `instana-haskell-trace-sdk.cabal` * `package.yaml` - * `test/integration/Instana/SDK/IntegrationTest/Metrics.hs` (assertion for `sensorVersion`) * Update `README.md` with API changes (if any). * Commit and push this change with a commit comment like `chore: version a.b.c.d` * Wait for the CI build for branch main. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -15,7 +15,7 @@ ``` extra-deps: -- instana-haskell-trace-sdk-0.9.0.0 +- instana-haskell-trace-sdk-0.10.0.0 ``` Depending on the stack resolver you use, you might also need to add `aeson-extra` to your extra-deps: diff --git a/instana-haskell-trace-sdk.cabal b/instana-haskell-trace-sdk.cabal --- a/instana-haskell-trace-sdk.cabal +++ b/instana-haskell-trace-sdk.cabal @@ -1,5 +1,5 @@ name: instana-haskell-trace-sdk -version: 0.9.0.0 +version: 0.10.0.0 synopsis: SDK for adding custom Instana tracing support to Haskell applications. description: Please also see the README on Github at homepage: https://www.instana.com/ @@ -230,6 +230,7 @@ base >=4.7 && <5 , aeson , aeson-casing + , containers , hslogger , servant , servant-server @@ -275,6 +276,7 @@ , array , bytestring , case-insensitive + , containers , directory , exceptions , hslogger diff --git a/src/Instana/SDK/Internal/W3CTraceContext.hs b/src/Instana/SDK/Internal/W3CTraceContext.hs --- a/src/Instana/SDK/Internal/W3CTraceContext.hs +++ b/src/Instana/SDK/Internal/W3CTraceContext.hs @@ -13,6 +13,7 @@ , W3CTraceContext(..) , createExitContextForSuppressed , decode + , emptyTraceState , exitSpanContextFromIds , inheritFrom , inheritFromForSuppressed @@ -57,7 +58,8 @@ -- |A representation of the flags part of the W3C trace context header -- traceparent. data Flags = Flags - { sampled :: Bool + { sampled :: Bool + , randomTraceId :: Bool } deriving (Eq, Generic, Show) @@ -136,12 +138,12 @@ flagsReadResult = readHex $ T.unpack $ rawFlags flgs :: Maybe Integer flgs = Maybe.listToMaybe . map fst $ flagsReadResult - smpld :: Bool - smpld = case flgs of + (smpld, rndmTrcId) = case flgs of Just fl -> - Bits.testBit fl 0 + (Bits.testBit fl 0, Bits.testBit fl 1) Nothing -> - False + (False, False) + in Just $ TraceParent { version = 0 @@ -149,6 +151,7 @@ , parentId = pId , flags = Flags { sampled = smpld + , randomTraceId = rndmTrcId } } _ -> @@ -336,6 +339,7 @@ , parentId = exitSpanSpanId , flags = Flags { sampled = True + , randomTraceId = randomTraceId $ flags parentTp } } , traceState = TraceState @@ -376,6 +380,7 @@ , parentId = exitSpanSpanId , flags = Flags { sampled = False + , randomTraceId = randomTraceId $ flags parentTp } } , traceState = TraceState @@ -397,6 +402,10 @@ , parentId = exitSpanSpanId , flags = Flags { sampled = True + -- There was no incoming W3C trace context, so we can assume that we + -- either created the trace ID ourselves, or another upstream Instana + -- tracer did so. In both cases, the trace ID is random. + , randomTraceId = True } } , traceState = TraceState @@ -428,6 +437,8 @@ , parentId = bogusParentId , flags = Flags { sampled = False + -- In this case, we have created the trace ID and we create them randomly. + , randomTraceId = True } } , traceState = TraceState @@ -478,8 +489,14 @@ -- |Encodes the traceparent flag field. encodeFlags :: Flags -> BSC8.ByteString encodeFlags fl = - if sampled fl then "01" - else "00" + if sampled fl && randomTraceId fl + then "03" + else if sampled fl + then "01" + else if randomTraceId fl + then "02" + else + "00" -- |Encodes the tracestate header value. diff --git a/test/agent-stub/Instana/SDK/AgentStub/Config.hs b/test/agent-stub/Instana/SDK/AgentStub/Config.hs --- a/test/agent-stub/Instana/SDK/AgentStub/Config.hs +++ b/test/agent-stub/Instana/SDK/AgentStub/Config.hs @@ -8,6 +8,7 @@ import Data.Maybe (fromMaybe) import Data.String (fromString) +import Data.Text (Text) import qualified Data.Text as T import GHC.Generics import Instana.SDK.AgentStub.DiscoveryResponse (SecretsConfig (SecretsConfig)) @@ -22,8 +23,8 @@ { bindHost :: Warp.HostPreference , bindPort :: Int , secretsConfig :: SecretsConfig - , extraHeadersViaTracingConfig :: Bool - , extraHeadersViaLegacyConfig :: Bool + , extraHeadersViaTracingConfig :: [Text] + , extraHeadersViaLegacyConfig :: [Text] , startupDelay :: Int , simulateConnectionLoss :: Bool , simulatPidTranslation :: Bool @@ -48,8 +49,8 @@ hostString <- lookupEnvWithDefault "HOST" "127.0.0.1" port <- lookupEnvIntWithDefault "PORT" 1302 secrets <- parseSecretsConfig - extraHeadersTracing <- lookupFlag "EXTRA_HEADERS_VIA_TRACING_CONFIG" - extraHeadersLegacy <- lookupFlag "EXTRA_HEADERS_VIA_LEGACY_CONFIG" + extraHeadersTracing <- parseExtraHeadersConfig "EXTRA_HEADERS_VIA_TRACING_CONFIG" + extraHeadersLegacy <- parseExtraHeadersConfig "EXTRA_HEADERS_VIA_LEGACY_CONFIG" delay <- lookupEnvIntWithDefault "STARTUP_DELAY" 0 connectionLoss <- lookupFlag "SIMULATE_CONNECTION_LOSS" pidTranslation <- lookupFlag "SIMULATE_PID_TRANSLATION" @@ -121,4 +122,14 @@ } Nothing -> do return defaultSecretsConfig + + +parseExtraHeadersConfig :: String -> IO [Text] +parseExtraHeadersConfig key = do + maybeExtraHeadersConfigString <- lookupEnv key + case maybeExtraHeadersConfigString of + Just extraHeadersString -> do + return $ T.splitOn "," (T.pack extraHeadersString) + Nothing -> do + return [] diff --git a/test/agent-stub/Instana/SDK/AgentStub/Server.hs b/test/agent-stub/Instana/SDK/AgentStub/Server.hs --- a/test/agent-stub/Instana/SDK/AgentStub/Server.hs +++ b/test/agent-stub/Instana/SDK/AgentStub/Server.hs @@ -81,29 +81,19 @@ translatedDiscoveryRequest = discoveryRequest { DiscoveryRequest.pid = show translatedPid } tracingConfig = - if Config.extraHeadersViaTracingConfig config + if length (Config.extraHeadersViaTracingConfig config) > 0 then Just TracingConfig { DiscoveryResponse.extraHttpHeaders = - Just - [ "X-Request-Header-On-Entry" - , "X-Response-Header-On-Entry" - , "X-Request-Header-On-Exit" - , "X-Response-Header-On-Exit" - ] + Just $ Config.extraHeadersViaTracingConfig config } else Nothing extraHeadersLegacyConfig = - if Config.extraHeadersViaLegacyConfig config + if length (Config.extraHeadersViaLegacyConfig config) > 0 then - Just - [ "X-Request-Header-On-Entry" - , "X-Response-Header-On-Entry" - , "X-Request-Header-On-Exit" - , "X-Response-Header-On-Exit" - ] + Just $ Config.extraHeadersViaLegacyConfig config else Nothing diff --git a/test/apps/downstream-target/Main.hs b/test/apps/downstream-target/Main.hs --- a/test/apps/downstream-target/Main.hs +++ b/test/apps/downstream-target/Main.hs @@ -90,6 +90,7 @@ HTTPTypes.status200 [ ("Content-Type", "application/json; charset=UTF-8") , ("X-Response-Header-On-Exit", "response header on exit value") + , ("X-Response-Header-Downstream-To-App", "Value 3") ] encodedHeaders diff --git a/test/apps/wai-with-middleware/Main.hs b/test/apps/wai-with-middleware/Main.hs --- a/test/apps/wai-with-middleware/Main.hs +++ b/test/apps/wai-with-middleware/Main.hs @@ -5,6 +5,7 @@ import Control.Concurrent (threadDelay) import Control.Monad.IO.Class (liftIO) import qualified Data.Binary.Builder as Builder +import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as LBSC8 import Instana.SDK.SDK (InstanaContext) import qualified Instana.SDK.SDK as InstanaSDK @@ -31,12 +32,8 @@ appLogger = "WaiWithMiddleware" -downstreamUrl :: String -downstreamUrl = "http://127.0.0.1:1208/echo?" ++ - "some=query&" ++ - "parameters=2&" ++ - "pass=secret" ++ - "will-be-obscured-when-custom-secrets-regex-is-configured" +downstreamBaseUrl :: String +downstreamBaseUrl = "http://127.0.0.1:1208/echo" application :: InstanaContext -> HTTP.Manager -> CPid -> Wai.Application @@ -83,7 +80,10 @@ -> Wai.Request -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived -apiUnderTest instana httpManager _ respond = do +apiUnderTest instana httpManager requestIn respond = do + let + query = BS.unpack $ Wai.rawQueryString requestIn + downstreamUrl = downstreamBaseUrl ++ query downstreamRequest <- HTTP.parseUrlThrow $ downstreamUrl downstreamResponse <- InstanaSDK.withHttpExit @@ -100,6 +100,7 @@ HTTPTypes.status200 [ ("Content-Type", "application/json; charset=UTF-8") , ("X-Response-Header-On-Entry", "response header on entry value") + , ("X-Response-Header-App-To-Test", "Value 4") ] (HTTP.responseBody downstreamResponse) @@ -113,7 +114,10 @@ -> Wai.Request -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived -apiUnderTestWithWrongNesting instana httpManager _ respond = do +apiUnderTestWithWrongNesting instana httpManager requestIn respond = do + let + query = BS.unpack $ Wai.rawQueryString requestIn + downstreamUrl = downstreamBaseUrl ++ query downstreamRequest <- HTTP.parseUrlThrow $ downstreamUrl InstanaSDK.withHttpExit @@ -133,6 +137,7 @@ HTTPTypes.status200 [ ("Content-Type", "application/json; charset=UTF-8") , ("X-Response-Header-On-Entry", "response header on entry value") + , ("X-Response-Header-App-To-Test", "Value 4") ] (HTTP.responseBody downstreamResponse) ) @@ -152,7 +157,9 @@ addDowntreamRequestHeaders request = request { HTTP.requestHeaders = - [ ("X-Request-Header-On-Exit", "request header on exit value") ] + [ ("X-Request-Header-On-Exit", "request header on exit value") + , ("X-Request-Header-App-To-Downstream", "Value 2") + ] } diff --git a/test/apps/wai/Main.hs b/test/apps/wai/Main.hs --- a/test/apps/wai/Main.hs +++ b/test/apps/wai/Main.hs @@ -38,6 +38,10 @@ appLogger = "WaiWarpApp" +downstreamBaseUrl :: String +downstreamBaseUrl = "http://127.0.0.1:1208/echo" + + application :: InstanaContext -> HTTP.Manager -> CPid -> Wai.Application application instana httpManager pid request respond = do let @@ -333,9 +337,11 @@ httpBracketApi instana httpManager requestIn respond = do response <- do InstanaSDK.withHttpEntry instana requestIn $ do + let + query = BS.unpack $ Wai.rawQueryString requestIn + downstreamUrl = downstreamBaseUrl ++ query downstreamRequest <- - HTTP.parseUrlThrow $ - "http://127.0.0.1:1208/echo?some=query¶meters=2&pass=secret" + HTTP.parseUrlThrow downstreamUrl downstreamResponse <- InstanaSDK.withHttpExit instana (addDowntreamRequestHeaders downstreamRequest) @@ -349,6 +355,7 @@ HTTPTypes.status200 [ ("Content-Type", "application/json; charset=UTF-8") , ("X-Response-Header-On-Entry", "response header on entry value") + , ("X-Response-Header-App-To-Test", "Value 4") ] (HTTP.responseBody downstreamResponse) respond response @@ -362,9 +369,11 @@ -> IO Wai.ResponseReceived httpLowLevelApi instana httpManager requestIn respond = do InstanaSDK.startHttpEntry instana requestIn + let + query = BS.unpack $ Wai.rawQueryString requestIn + downstreamUrl = downstreamBaseUrl ++ query downstreamRequest <- - HTTP.parseUrlThrow $ - "http://127.0.0.1:1208/echo?some=query¶meters=2&pass=secret" + HTTP.parseUrlThrow downstreamUrl downstreamRequest' <- InstanaSDK.startHttpExit instana $ addDowntreamRequestHeaders downstreamRequest @@ -377,6 +386,7 @@ HTTPTypes.status200 [ ("Content-Type", "application/json; charset=UTF-8") , ("X-Response-Header-On-Entry", "response header on entry value") + , ("X-Response-Header-App-To-Test", "Value 4") ] (HTTP.responseBody downstreamResponse) response' <- @@ -421,7 +431,9 @@ addDowntreamRequestHeaders request = request { HTTP.requestHeaders = - [ ("X-Request-Header-On-Exit", "request header on exit value") ] + [ ("X-Request-Header-On-Exit", "request header on exit value") + , ("X-Request-Header-App-To-Downstream", "Value 2") + ] } diff --git a/test/integration/Instana/SDK/IntegrationTest/CustomSecrets.hs b/test/integration/Instana/SDK/IntegrationTest/CustomSecrets.hs --- a/test/integration/Instana/SDK/IntegrationTest/CustomSecrets.hs +++ b/test/integration/Instana/SDK/IntegrationTest/CustomSecrets.hs @@ -80,7 +80,14 @@ [ "http" .= (Aeson.object [ "method" .= ("GET" :: String) , "url" .= ("http://127.0.0.1:1208/echo" :: String) - , "params" .= ("some=query¶meters=2&pass=secret" :: String) + , "params" .= ( + "api-key=1234&" + ++ "hidden-param=&" + ++ "MYPASSWORD=abc&" + ++ "this-will-be-obscured-by-the-regex-matcher=&" + ++ "secret=yes&" + ++ "not-hidden=value" :: String + ) , "status" .= (200 :: Int) ] ) diff --git a/test/integration/Instana/SDK/IntegrationTest/ExtraHttpHeaders.hs b/test/integration/Instana/SDK/IntegrationTest/ExtraHttpHeaders.hs --- a/test/integration/Instana/SDK/IntegrationTest/ExtraHttpHeaders.hs +++ b/test/integration/Instana/SDK/IntegrationTest/ExtraHttpHeaders.hs @@ -65,7 +65,6 @@ [ "method" .= ("GET" :: String) , "url" .= ("http://127.0.0.1:1208/echo" :: String) , "status" .= (200 :: Int) - , "params" .= ("some=query¶meters=2&pass=" :: String) , "header" .= (Aeson.object [ "X-Request-Header-On-Exit" .= ("request header on exit value" :: String) , "X-Response-Header-On-Exit" .= ("response header on exit value" :: String) diff --git a/test/integration/Instana/SDK/IntegrationTest/HttpTracing.hs b/test/integration/Instana/SDK/IntegrationTest/HttpTracing.hs --- a/test/integration/Instana/SDK/IntegrationTest/HttpTracing.hs +++ b/test/integration/Instana/SDK/IntegrationTest/HttpTracing.hs @@ -113,7 +113,7 @@ shouldRedactDefaultSecrets :: String -> IO Test shouldRedactDefaultSecrets pid = applyLabel "shouldRedactDefaultSecrets" $ - runTest + runHttpTest pid "http/bracket/api?query-param=value&api-key=1234&MYPASSWORD=abc&another-query-param=zzz1&secret=yes" [] @@ -121,6 +121,21 @@ [ rootEntryAsserts , filterDefaultSecretsAsserts ]) + (\exitSpan -> + [ assertEqual "exit data" + ( Aeson.object + [ "http" .= (Aeson.object + [ "method" .= ("GET" :: String) + , "url" .= ("http://127.0.0.1:1208/echo" :: String) + , "params" .= ("query-param=value&api-key=&MYPASSWORD=&another-query-param=zzz1&secret=" :: String) + , "status" .= (200 :: Int) + ] + ) + ] + ) + (TraceRequest.spanData exitSpan) + ] + ) shouldCreateRootEntryWithLowLevelApi :: String -> IO Test @@ -197,7 +212,7 @@ runLowLevelTest :: String -> [Header] -> (Span -> [Assertion]) -> IO Test runLowLevelTest pid headers extraAssertsForEntrySpan = - runTest pid "http/low/level/api?some=query¶meters=2" headers extraAssertsForEntrySpan + runTest pid "http/low/level/api?some=query¶meters=1" headers extraAssertsForEntrySpan runTest :: String -> String -> [Header] -> (Span -> [Assertion]) -> IO Test @@ -213,7 +228,7 @@ [ "http" .= (Aeson.object [ "method" .= ("GET" :: String) , "url" .= ("http://127.0.0.1:1208/echo" :: String) - , "params" .= ("some=query¶meters=2&pass=" :: String) + , "params" .= ("some=query¶meters=1" :: String) , "status" .= (200 :: Int) ] ) @@ -412,7 +427,7 @@ [ "method" .= ("GET" :: String) , "host" .= ("127.0.0.1:1207" :: String) , "url" .= ("/http/low/level/api" :: String) - , "params" .= ("some=query¶meters=2" :: String) + , "params" .= ("some=query¶meters=1" :: String) , "status" .= (200 :: Int) ] ) diff --git a/test/integration/Instana/SDK/IntegrationTest/Metrics.hs b/test/integration/Instana/SDK/IntegrationTest/Metrics.hs --- a/test/integration/Instana/SDK/IntegrationTest/Metrics.hs +++ b/test/integration/Instana/SDK/IntegrationTest/Metrics.hs @@ -49,10 +49,6 @@ "arguments" "" (EntityDataRequest.arguments entityData) - , assertLabelIs - "sensorVersion" - "0.9.0.0" - (EntityDataRequest.sensorVersion entityData) , assertCounterSatisfies "startTime" (1545570995405 <) diff --git a/test/integration/Instana/SDK/IntegrationTest/Runner.hs b/test/integration/Instana/SDK/IntegrationTest/Runner.hs --- a/test/integration/Instana/SDK/IntegrationTest/Runner.hs +++ b/test/integration/Instana/SDK/IntegrationTest/Runner.hs @@ -128,9 +128,9 @@ booleanEnv $ Suite.simulateConnectionLoss options) , ("SECRETS_CONFIG", Suite.customSecretsConfig options) , ("EXTRA_HEADERS_VIA_TRACING_CONFIG", - booleanEnv $ Suite.tracingConfigForExtraHeaders options) + stringListEnv $ Suite.tracingConfigForExtraHeaders options) , ("EXTRA_HEADERS_VIA_LEGACY_CONFIG", - booleanEnv $ Suite.legacyConfigForExtraHeaders options) + stringListEnv $ Suite.legacyConfigForExtraHeaders options) , ("LOG_LEVEL", Just logLevel) ] "stack exec instana-haskell-agent-stub" @@ -320,6 +320,13 @@ booleanEnv :: Bool -> Maybe String booleanEnv b = if b then Just "true" else Nothing + + +stringListEnv :: [String] -> Maybe String +stringListEnv strings = + if length strings > 0 + then Just $ T.unpack $ T.intercalate "," (map T.pack strings) + else Nothing -- |Environment variable for the log level diff --git a/test/integration/Instana/SDK/IntegrationTest/SpecCompliance.hs b/test/integration/Instana/SDK/IntegrationTest/SpecCompliance.hs --- a/test/integration/Instana/SDK/IntegrationTest/SpecCompliance.hs +++ b/test/integration/Instana/SDK/IntegrationTest/SpecCompliance.hs @@ -7,7 +7,7 @@ import Control.Concurrent (threadDelay) -import Data.Aeson ((.:), (.:?), (.=)) +import Data.Aeson ((.:), (.:?)) import qualified Data.Aeson as Aeson import Data.Aeson.Types (FromJSON) import qualified Data.Aeson.Types as AesonTypes @@ -16,15 +16,19 @@ import qualified Data.ByteString.Char8 as BSC8 import qualified Data.ByteString.Lazy.Char8 as LBSC8 import qualified Data.CaseInsensitive as CI +import Data.Either (isLeft) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap -import Data.Maybe (catMaybes, isNothing, - listToMaybe) +import qualified Data.Map as Map +import Data.Maybe (catMaybes, isJust, + isNothing, listToMaybe) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Vector as Vector import Instana.SDK.AgentStub.TraceRequest (From (..), - InstanaAncestor, Span) + HttpAnnotations, + InstanaAncestor, Span, + SpanData) import qualified Instana.SDK.AgentStub.TraceRequest as TraceRequest import Instana.SDK.IntegrationTest.HUnitExtra (applyLabel, assertAllIO, failIO) @@ -44,6 +48,7 @@ | RunSubset [Int] +-- replace RunAll with RunSubset[...] to run test cases selectively testCasesToRun :: RunSubsetOfCases testCasesToRun = RunAll @@ -97,6 +102,8 @@ , xInstanaSyntheticIn :: Maybe String , traceparentIn :: Maybe String , tracestateIn :: Maybe String + , queryIn :: Maybe String + , requestHeadersIn :: Maybe String , serverTiming :: Maybe String , entrySpanT :: Maybe String , entrySpanP :: Maybe String @@ -107,6 +114,9 @@ , entrySpanCrid :: Maybe String , entrySpanCrtp :: Maybe String , entrySpanSy :: Maybe Bool + , entrySpanParams :: Maybe String + , entrySpanHeaders :: Maybe String + , entrySpanService :: Maybe String , exitSpanT :: Maybe String , exitSpanP :: Maybe String , exitSpanS :: Maybe String @@ -116,6 +126,9 @@ , exitSpanCrid :: Maybe String , exitSpanCrtp :: Maybe String , exitSpanSy :: Maybe Bool + , exitSpanParams :: Maybe String + , exitSpanHeaders :: Maybe String + , exitSpanService :: Maybe String , xInstanaTOut :: Maybe String , xInstanaSOut :: Maybe String , xInstanaLOut :: Maybe String @@ -130,7 +143,7 @@ \obj -> SpecTestCase <$> obj .: "index" - <*> obj .: "Scenario/incoming headers" + <*> obj .: "Scenario" <*> obj .: "What to do?" <*> obj .:? "INSTANA_DISABLE_W3C_TRACE_CORRELATION" <*> obj .:? "X-INSTANA-T in" @@ -139,6 +152,8 @@ <*> obj .:? "X-INSTANA-SYNTHETIC in" <*> obj .:? "traceparent in" <*> obj .:? "tracestate in" + <*> obj .:? "query in" + <*> obj .:? "request headers in" <*> obj .:? "Server-Timing" <*> obj .:? "entrySpan.t" <*> obj .:? "entrySpan.p" @@ -149,6 +164,9 @@ <*> obj .:? "entrySpan.crid" <*> obj .:? "entrySpan.crtp" <*> obj .:? "entrySpan.sy" + <*> obj .:? "entrySpan.params" + <*> obj .:? "entrySpan.headers" + <*> obj .:? "entrySpan.data.service" <*> obj .:? "exitSpan.t" <*> obj .:? "exitSpan.p" <*> obj .:? "exitSpan.s" @@ -158,6 +176,9 @@ <*> obj .:? "exitSpan.crid" <*> obj .:? "exitSpan.crtp" <*> obj .:? "exitSpan.sy" + <*> obj .:? "exitSpan.params" + <*> obj .:? "exitSpan.headers" + <*> obj .:? "exitSpan.data.service" <*> obj .:? "X-INSTANA-T out" <*> obj .:? "X-INSTANA-S out" <*> obj .:? "X-INSTANA-L out" @@ -331,29 +352,51 @@ (show $ index testCaseDefinition) ++ ": " ++ scenario testCaseDefinition ++ " -> " ++ whatToDo testCaseDefinition - headers = testCaseDefinitionToHeaders testCaseDefinition - putStrLn $ "Creating test: " ++ label ++ "\nwith headers:\n" ++ show headers + requestHeaders = testCaseDefinitionToHeaders testCaseDefinition + routeWithQuery = + case queryIn testCaseDefinition of + Just query -> route ++ "?" ++ query + Nothing -> route + putStrLn $ + "Creating test: " ++ label ++ + "\nwith requestHeaders:\n" ++ show requestHeaders putStrLn $ "TEST CASE: " ++ show testCaseDefinition applyLabel label $ runSpecTestCase appUnderTest route + routeWithQuery pid - headers + requestHeaders testCaseDefinition testCaseDefinitionToHeaders :: SpecTestCase -> [Header] testCaseDefinitionToHeaders testCaseDefinition = - catMaybes $ - map toHeader - [ ("X-INSTANA-T", xInstanaTIn testCaseDefinition) - , ("X-INSTANA-S", xInstanaSIn testCaseDefinition) - , ("X-INSTANA-L", xInstanaLIn testCaseDefinition) - , ("X-INSTANA-SYNTHETIC", xInstanaSyntheticIn testCaseDefinition) - , ("traceparent", traceparentIn testCaseDefinition) - , ("tracestate", tracestateIn testCaseDefinition) - ] + let + traceCorrelationHeaders = + catMaybes $ + map toHeader + [ ("X-INSTANA-T", xInstanaTIn testCaseDefinition) + , ("X-INSTANA-S", xInstanaSIn testCaseDefinition) + , ("X-INSTANA-L", xInstanaLIn testCaseDefinition) + , ("X-INSTANA-SYNTHETIC", xInstanaSyntheticIn testCaseDefinition) + , ("traceparent", traceparentIn testCaseDefinition) + , ("tracestate", tracestateIn testCaseDefinition) + ] + extraRequestHeaders :: [Header] + extraRequestHeaders = + case requestHeadersIn testCaseDefinition of + Just requestHeader -> + let + [name, value] = T.splitOn ":" $ T.pack requestHeader + headerName = CI.mk $ BSC8.pack $ T.unpack name + headerValue = BSC8.pack $ T.unpack value + in + [(headerName, headerValue)] + Nothing -> [] + in + traceCorrelationHeaders ++ extraRequestHeaders where toHeader (_, Nothing) = Nothing toHeader (name, Just value) = Just (name, BSC8.pack value) @@ -363,10 +406,17 @@ AppUnderTest -> String -> String + -> String -> [Header] -> SpecTestCase -> IO Test -runSpecTestCase appUnderTest route pid headers testCaseDefinition = do +runSpecTestCase + appUnderTest + expectedEntryUrl + routeWithQuery + pid + requestHeaders + testCaseDefinition = do let suppressionHeader = filter @@ -374,16 +424,17 @@ (name == (CI.mk (BSC8.pack "X-INSTANA-L"))) && (value == BSC8.pack "0") ) - headers + requestHeaders suppressed = (length suppressionHeader) >= 1 executeRequestAndVerify appUnderTest testCaseDefinition - route + expectedEntryUrl + routeWithQuery pid suppressed - headers + requestHeaders executeRequestAndVerify :: @@ -391,22 +442,24 @@ -> SpecTestCase -> String -> String + -> String -> Bool -> [Header] -> IO Test executeRequestAndVerify appUnderTest testCaseDefinition - route + expectedEntryUrl + routeWithQuery pid suppressed - headers = do + requestHeaders = do response <- HttpHelper.doAppRequest appUnderTest - (route ++ "?some=query¶meters=1") + routeWithQuery "GET" - headers + requestHeaders let initialTestContext = ([], []) @@ -436,7 +489,7 @@ verifySpans testCaseDefinition testContextAfterDownstreamHeaderCheck - route + expectedEntryUrl responseBody from @@ -515,10 +568,10 @@ testContext in foldr - (\(header, accessor) currentTestContext -> + (\(headerName, accessor) currentTestContext -> let message = - "value for downstream HTTP header " ++ (T.unpack header) + "value for downstream HTTP header " ++ (T.unpack headerName) expectedValueM :: Maybe String expectedValueM = accessor testCaseDefinition in @@ -530,14 +583,14 @@ currentTestContext message expectedValue - (HashMap.lookup header responseBody) + (HashMap.lookup headerName responseBody) else addAssertion - (assertEqualInMap message expectedValue header responseBody) + (assertEqualInMap message expectedValue headerName responseBody) currentTestContext Nothing -> addAssertion - (assertNotInMap message header responseBody) + (assertNotInMap message headerName responseBody) currentTestContext ) testContextAfterXInstanaLCheck @@ -583,7 +636,7 @@ verifySpans testCaseDefinition testContext - route + expectedEntryUrl responseBody from = do spansResults <- @@ -604,20 +657,48 @@ else do let Just entrySpan = maybeEntrySpan + entrySpanDataAeson = (TraceRequest.spanData entrySpan) + entryHttpAnnotationsEither :: Either String HttpAnnotations + entryHttpAnnotationsEither = + fmap TraceRequest.httpAnnotations $ + (AesonTypes.parseEither + Aeson.parseJSON + entrySpanDataAeson :: Either String SpanData) Just exitSpan = maybeExitSpan - (assertions, _) = - (spanAssertions - testCaseDefinition - testContext - route - entrySpan - exitSpan - from - ) + exitSpanDataAeson = (TraceRequest.spanData exitSpan) + exitHttpAnnotationsEither :: Either String HttpAnnotations + exitHttpAnnotationsEither = + fmap TraceRequest.httpAnnotations $ + (AesonTypes.parseEither + Aeson.parseJSON + exitSpanDataAeson :: Either String SpanData) putStrLn $ "ENTRY " ++ show entrySpan putStrLn $ "EXIT " ++ show exitSpan putStrLn $ "RESPONSE " ++ show responseBody - assertAllIO $ assertions + if isLeft entryHttpAnnotationsEither then do + let + Left msg = entryHttpAnnotationsEither + failIO $ "Could not parse annotations of HTTP entry span: " ++ msg + else if isLeft exitHttpAnnotationsEither then do + let + Left msg = exitHttpAnnotationsEither + failIO $ "Could not parse annotations of HTTP entry span: " ++ msg + else do + let + Right entryHttpAnnotations = entryHttpAnnotationsEither + Right exitHttpAnnotations = exitHttpAnnotationsEither + (assertions, _) = + (spanAssertions + testCaseDefinition + testContext + expectedEntryUrl + entrySpan + entryHttpAnnotations + exitSpan + exitHttpAnnotations + from + ) + assertAllIO $ assertions spanAssertions :: @@ -625,18 +706,33 @@ -> TestContext -> String -> Span + -> HttpAnnotations -> Span + -> HttpAnnotations -> Maybe From -> TestContext spanAssertions testCaseDefinition testContext - route + expectedEntryUrl entrySpan + entryHttpAnnotations exitSpan + exitHttpAnnotations from = addAssertions - (fixedSpanAssertions route entrySpan exitSpan from) + (basicSpanAssertions + testCaseDefinition + entrySpan + exitSpan + from + ++ + httpAnnotationAssertions + testCaseDefinition + expectedEntryUrl + entryHttpAnnotations + exitHttpAnnotations + ) (spanAssertionsFromTestCaseDefinition testCaseDefinition testContext @@ -645,51 +741,169 @@ ) -fixedSpanAssertions :: - String +basicSpanAssertions :: + SpecTestCase -> Span -> Span -> Maybe From -> [Assertion] -fixedSpanAssertions route entrySpan exitSpan from = +basicSpanAssertions + testCaseDefinition + entrySpan + exitSpan + from = [ assertBool "entry timestamp" $ TraceRequest.ts entrySpan > 0 , assertBool "entry duration" $ TraceRequest.d entrySpan > 0 , assertEqual "entry kind" 1 (TraceRequest.k entrySpan) , assertEqual "entry error count" 0 (TraceRequest.ec entrySpan) , assertEqual "entry from" from $ TraceRequest.f entrySpan - , assertEqual "entry data" - ( Aeson.object - [ "http" .= (Aeson.object - [ "method" .= ("GET" :: String) - , "host" .= ("127.0.0.1:1207" :: String) - , "url" .= ("/" ++ route) - , "params" .= ("some=query¶meters=1" :: String) - , "status" .= (200 :: Int) - ] - ) - ] - ) - (TraceRequest.spanData entrySpan) , assertBool "exit timestamp" $ TraceRequest.ts exitSpan > 0 , assertBool "exit duration" $ TraceRequest.d exitSpan > 0 , assertEqual "exit kind" 2 (TraceRequest.k exitSpan) , assertEqual "exit error count" 0 (TraceRequest.ec exitSpan) , assertEqual "exit from" from $ TraceRequest.f exitSpan - , assertEqual "exit data" - ( Aeson.object - [ "http" .= (Aeson.object - [ "method" .= ("GET" :: String) - , "url" .= ("http://127.0.0.1:1208/echo" :: String) - , "params" .= ("some=query¶meters=2&pass=" :: String) - , "status" .= (200 :: Int) - ] - ) + ] + ++ + (verifyService testCaseDefinition entrySpanService "entry" entrySpan) + ++ + (verifyService testCaseDefinition exitSpanService "exit" exitSpan) + + +verifyService :: + SpecTestCase + -> (SpecTestCase -> Maybe String) + -> String + -> Span + -> [Assertion] +verifyService testCaseDefinition expectedServiceAccessor label span_ = + let + expectedService = expectedServiceAccessor testCaseDefinition + in + if isJust expectedService + then + [ assertEqual + (label ++ " service") + (fmap T.pack expectedService) + (TraceRequest.readService span_) ] - ) - (TraceRequest.spanData exitSpan) + else [] + + +httpAnnotationAssertions :: + SpecTestCase + -> String + -> HttpAnnotations + -> HttpAnnotations + -> [Assertion] +httpAnnotationAssertions + testCaseDefinition + expectedEntryUrl + entryHttpAnnotations + exitHttpAnnotations = + [ -- entry span http annotations + assertEqual "entry http method" + (Just "GET" :: Maybe String) + (TraceRequest.method entryHttpAnnotations) + , assertEqual "entry http host" + (Just "127.0.0.1:1207" :: Maybe String) + (TraceRequest.host entryHttpAnnotations) + , assertEqual "entry http url" + (Just ("/" ++ expectedEntryUrl) :: Maybe String) + (TraceRequest.url entryHttpAnnotations) + , assertEqual "entry http params" + (entrySpanParams testCaseDefinition) + (TraceRequest.params entryHttpAnnotations) + , assertEqual "entry http status" + (Just 200 :: Maybe Int) + (TraceRequest.status entryHttpAnnotations) + + -- exit span http annotations + , assertEqual "exit http method" + (Just "GET" :: Maybe String) + (TraceRequest.method exitHttpAnnotations) + , assertEqual "exit http url" + (Just "http://127.0.0.1:1208/echo" :: Maybe String) + (TraceRequest.url exitHttpAnnotations) + , assertEqual "exit http params" + (exitSpanParams testCaseDefinition) + (TraceRequest.params exitHttpAnnotations) + , assertEqual "exit http status" + (Just 200 :: Maybe Int) + (TraceRequest.status exitHttpAnnotations) ] + ++ + allHeaderAssertions + testCaseDefinition + entryHttpAnnotations + exitHttpAnnotations +allHeaderAssertions :: + SpecTestCase + -> HttpAnnotations + -> HttpAnnotations + -> [Assertion] +allHeaderAssertions + testCaseDefinition + entryHttpAnnotations + exitHttpAnnotations = + headerAssertions + testCaseDefinition + entrySpanHeaders + "entry" + entryHttpAnnotations + ++ + headerAssertions + testCaseDefinition + exitSpanHeaders + "exit" + exitHttpAnnotations + + +headerAssertions :: + SpecTestCase + -> (SpecTestCase -> Maybe String) + -> String + -> HttpAnnotations + -> [Assertion] +headerAssertions + testCaseDefinition + expectedHeaderAccessor + label + httpAnnotations = + if isNothing (expectedHeaderAccessor testCaseDefinition) + then + [] + else + let + Just expectedHeaderString = expectedHeaderAccessor testCaseDefinition + [expectedHeaderName, expectedHeaderValue] = + map T.unpack $ + map T.strip $ + T.splitOn ":" $ + T.pack expectedHeaderString + actualHeadersMaybe = TraceRequest.header httpAnnotations + in + if isNothing actualHeadersMaybe + then + [ assertBool + ("expected " ++ label ++ " http header " ++ + expectedHeaderName ++ + "but no headers were captured") + False + ] + else + let + Just actualHeaders = actualHeadersMaybe + actualHeaderValue = + Map.lookup expectedHeaderName actualHeaders + in + [ assertEqual (label ++ " http header " ++ expectedHeaderName) + (Just expectedHeaderValue) + actualHeaderValue + ] + + spanAssertionsFromTestCaseDefinition :: SpecTestCase -> TestContext @@ -703,9 +917,15 @@ exitSpan = let testContextAfterEntrySpanChecks = - verifyEntrySpan testCaseDefinition testContext entrySpan + verifyEntrySpan + testCaseDefinition + testContext + entrySpan in - verifyExitSpan testCaseDefinition testContextAfterEntrySpanChecks exitSpan + verifyExitSpan + testCaseDefinition + testContextAfterEntrySpanChecks + exitSpan verifyEntrySpan :: diff --git a/test/integration/Instana/SDK/IntegrationTest/Suite.hs b/test/integration/Instana/SDK/IntegrationTest/Suite.hs --- a/test/integration/Instana/SDK/IntegrationTest/Suite.hs +++ b/test/integration/Instana/SDK/IntegrationTest/Suite.hs @@ -39,8 +39,8 @@ , simulateConnectionLoss :: Bool , customServiceName :: Maybe String , customSecretsConfig :: Maybe String - , tracingConfigForExtraHeaders :: Bool - , legacyConfigForExtraHeaders :: Bool + , tracingConfigForExtraHeaders :: [String] + , legacyConfigForExtraHeaders :: [String] , disableW3cTraceCorrelation :: Bool , appsUnderTest :: [AppUnderTest] } @@ -63,8 +63,8 @@ , simulateConnectionLoss = False , customServiceName = Nothing , customSecretsConfig = Nothing - , tracingConfigForExtraHeaders = False - , legacyConfigForExtraHeaders = False + , tracingConfigForExtraHeaders = [] + , legacyConfigForExtraHeaders = [] , disableW3cTraceCorrelation = False , appsUnderTest = [testServer] } @@ -124,12 +124,26 @@ withTracingConfigForExtraHeaders :: SuiteOptions withTracingConfigForExtraHeaders = - defaultOptions { tracingConfigForExtraHeaders = True } + defaultOptions { + tracingConfigForExtraHeaders = + [ "X-Request-Header-On-Entry" + , "X-Response-Header-On-Entry" + , "X-Request-Header-On-Exit" + , "X-Response-Header-On-Exit" + ] + } withLegacyConfigForExtraHeaders :: SuiteOptions withLegacyConfigForExtraHeaders = - defaultOptions { legacyConfigForExtraHeaders = True } + defaultOptions { + legacyConfigForExtraHeaders = + [ "X-Request-Header-On-Entry" + , "X-Response-Header-On-Entry" + , "X-Request-Header-On-Exit" + , "X-Response-Header-On-Exit" + ] + } withW3cTraceCorrelationDisabled :: SuiteOptions diff --git a/test/integration/Instana/SDK/IntegrationTest/TestSuites.hs b/test/integration/Instana/SDK/IntegrationTest/TestSuites.hs --- a/test/integration/Instana/SDK/IntegrationTest/TestSuites.hs +++ b/test/integration/Instana/SDK/IntegrationTest/TestSuites.hs @@ -207,8 +207,16 @@ specificationComplianceTestCases Suite.testServer route - , Suite.options = Suite.defaultOptions { - Suite.appsUnderTest = + , Suite.options = Suite.defaultOptions + { Suite.customSecretsConfig = Just "contains-ignore-case:password,secret,token" + , Suite.tracingConfigForExtraHeaders = + [ "X-Request-Header-Test-To-App" + , "X-Request-Header-App-To-Downstream" + , "X-Response-Header-Downstream-To-App" + , "X-Response-Header-App-To-Test" + ] + , Suite.customServiceName = Just "Tracer Test Suite Service" + , Suite.appsUnderTest = [ Suite.testServer , Suite.downstreamTarget ] @@ -228,8 +236,17 @@ specificationComplianceTestCases Suite.testServer route - , Suite.options = Suite.withW3cTraceCorrelationDisabled { - Suite.appsUnderTest = + , Suite.options = Suite.defaultOptions + { Suite.customSecretsConfig = Just "contains-ignore-case:password,secret,token" + , Suite.tracingConfigForExtraHeaders = + [ "X-Request-Header-Test-To-App" + , "X-Request-Header-App-To-Downstream" + , "X-Response-Header-Downstream-To-App" + , "X-Response-Header-App-To-Test" + ] + , Suite.customServiceName = Just "Tracer Test Suite Service" + , Suite.disableW3cTraceCorrelation = True + , Suite.appsUnderTest = [ Suite.testServer , Suite.downstreamTarget ] @@ -266,8 +283,16 @@ specificationComplianceTestCases Suite.testServerWithMiddleware route - , Suite.options = Suite.defaultOptions { - Suite.appsUnderTest = + , Suite.options = Suite.defaultOptions + { Suite.customSecretsConfig = Just "contains-ignore-case:password,secret,token" + , Suite.tracingConfigForExtraHeaders = + [ "X-Request-Header-Test-To-App" + , "X-Request-Header-App-To-Downstream" + , "X-Response-Header-Downstream-To-App" + , "X-Response-Header-App-To-Test" + ] + , Suite.customServiceName = Just "Tracer Test Suite Service" + , Suite.appsUnderTest = [ Suite.testServerWithMiddleware , Suite.downstreamTarget ] @@ -289,8 +314,17 @@ specificationComplianceTestCases Suite.testServerWithMiddleware route - , Suite.options = Suite.withW3cTraceCorrelationDisabled { - Suite.appsUnderTest = + , Suite.options = Suite.defaultOptions + { Suite.customSecretsConfig = Just "contains-ignore-case:password,secret,token" + , Suite.tracingConfigForExtraHeaders = + [ "X-Request-Header-Test-To-App" + , "X-Request-Header-App-To-Downstream" + , "X-Response-Header-Downstream-To-App" + , "X-Response-Header-App-To-Test" + ] + , Suite.customServiceName = Just "Tracer Test Suite Service" + , Suite.disableW3cTraceCorrelation = True + , Suite.appsUnderTest = [ Suite.testServerWithMiddleware , Suite.downstreamTarget ] diff --git a/test/integration/Instana/SDK/IntegrationTest/WaiMiddleware.hs b/test/integration/Instana/SDK/IntegrationTest/WaiMiddleware.hs --- a/test/integration/Instana/SDK/IntegrationTest/WaiMiddleware.hs +++ b/test/integration/Instana/SDK/IntegrationTest/WaiMiddleware.hs @@ -239,7 +239,7 @@ [ "http" .= (Aeson.object [ "method" .= ("GET" :: String) , "url" .= ("http://127.0.0.1:1208/echo" :: String) - , "params" .= ("some=query¶meters=2&pass=" :: String) + , "params" .= ("some=query¶meters=1" :: String) , "status" .= (200 :: Int) ] ) diff --git a/test/shared/Instana/SDK/AgentStub/TraceRequest.hs b/test/shared/Instana/SDK/AgentStub/TraceRequest.hs --- a/test/shared/Instana/SDK/AgentStub/TraceRequest.hs +++ b/test/shared/Instana/SDK/AgentStub/TraceRequest.hs @@ -8,6 +8,7 @@ (.:?), (.=)) import qualified Data.Aeson as Aeson import qualified Data.HashMap.Strict as HM +import Data.Map (Map) import Data.Text (Text) import GHC.Generics @@ -123,6 +124,43 @@ ] +data SpanData = SpanData + { httpAnnotations :: HttpAnnotations + } + deriving (Show) + + +instance FromJSON SpanData where + parseJSON = Aeson.withObject "Span Annotations" $ + \obj -> + SpanData + <$> obj .: "http" + + +data HttpAnnotations = HttpAnnotations + { method :: Maybe String + , host :: Maybe String + , url :: Maybe String + , params :: Maybe String + -- ("header",Object (fromList [("X-Response-Header-Downstream-To-App",String "Value 3"),("X-Request-Header-App-To-Downstream",String "Value 2")]))]))]), + , header :: Maybe (Map String String) + , status :: Maybe Int + } + deriving (Show) + + +instance FromJSON HttpAnnotations where + parseJSON = Aeson.withObject "HTTP Annotations" $ + \obj -> + HttpAnnotations + <$> obj .:? "method" + <*> obj .:? "host" + <*> obj .:? "url" + <*> obj .:? "params" + <*> obj .:? "header" + <*> obj .:? "status" + + readSdkName :: Span -> Maybe Text readSdkName span_ = let @@ -130,6 +168,16 @@ in case value of Just (Aeson.String sdkName) -> Just sdkName + _ -> Nothing + + +readService :: Span -> Maybe Text +readService span_ = + let + value = extractProperty ["service"] (spanData span_) + in + case value of + Just (Aeson.String service) -> Just service _ -> Nothing diff --git a/test/unit/Instana/SDK/Internal/SpanStackTest.hs b/test/unit/Instana/SDK/Internal/SpanStackTest.hs --- a/test/unit/Instana/SDK/Internal/SpanStackTest.hs +++ b/test/unit/Instana/SDK/Internal/SpanStackTest.hs @@ -429,6 +429,7 @@ , parentId = "span-id" , flags = Flags { sampled = False + , randomTraceId = False } } , traceState = TraceState diff --git a/test/unit/Instana/SDK/Internal/W3CTraceContextTest.hs b/test/unit/Instana/SDK/Internal/W3CTraceContextTest.hs --- a/test/unit/Instana/SDK/Internal/W3CTraceContextTest.hs +++ b/test/unit/Instana/SDK/Internal/W3CTraceContextTest.hs @@ -53,12 +53,18 @@ "shouldDecodeInvalidFlagsContentToNothing" shouldDecodeInvalidFlagsContentToNothing , TestLabel - "shouldDecodeValidTraceParent" - shouldDecodeValidTraceParent + "shouldDecodeValidTraceParentWithoutRandomTraceId" + shouldDecodeValidTraceParentWithoutRandomTraceId , TestLabel - "shouldDecodeUnsampledTraceParent" - shouldDecodeUnsampledTraceParent + "shouldDecodeValidTraceParentWithRandomTraceId" + shouldDecodeValidTraceParentWithRandomTraceId , TestLabel + "shouldDecodeUnsampledTraceParentWithoutRandomTraceId" + shouldDecodeUnsampledTraceParentWithoutRandomTraceId + , TestLabel + "shouldDecodeUnsampledTraceParentWithRandomTraceId" + shouldDecodeUnsampledTraceParentWithRandomTraceId + , TestLabel "shouldDecodeKnownPartsFromHigherVersionTraceParent" shouldDecodeKnownPartsFromHigherVersionTraceParent , TestLabel @@ -107,6 +113,9 @@ "shouldInherit" shouldInherit , TestLabel + "shouldInheritUnsetRandomTraceIdFlag" + shouldInheritUnsetRandomTraceIdFlag + , TestLabel "shouldInheritForSuppressed" shouldInheritForSuppressed , TestLabel @@ -116,9 +125,18 @@ "shouldCreateExitForSuppressed" shouldCreateExitForSuppressed , TestLabel - "shouldEncodeToHeaders" - shouldEncodeToHeaders + "shouldEncodeToHeadersSampledWithRandomTraceId" + shouldEncodeToHeadersSampledWithRandomTraceId , TestLabel + "shouldEncodeToHeadersUnsampledWithRandomTraceId" + shouldEncodeToHeadersUnsampledWithRandomTraceId + , TestLabel + "shouldEncodeToHeadersSampledWithoutRandomTraceId" + shouldEncodeToHeadersSampledWithoutRandomTraceId + , TestLabel + "shouldEncodeToHeadersUnsampledWithoutRandomTraceId" + shouldEncodeToHeadersUnsampledWithoutRandomTraceId + , TestLabel "shouldPadShortIds" shouldPadShortIds , TestLabel @@ -190,15 +208,15 @@ "00-1234567890abcdeffedcba0987654321-24680bdf13579abc-XX" -shouldDecodeValidTraceParent :: Test -shouldDecodeValidTraceParent = +shouldDecodeValidTraceParentWithoutRandomTraceId :: Test +shouldDecodeValidTraceParentWithoutRandomTraceId = let actual = W3CTraceContext.decode "00-1234567890abcdeffedcba0987654321-24680bdf13579abc-01" Nothing expected = - sampledWithoutTraceState + sampledNoRandomTraceIdWithoutTraceState "1234567890abcdeffedcba0987654321" "24680bdf13579abc" in @@ -206,15 +224,31 @@ assertEqual "W3C Trace Context" expected actual -shouldDecodeUnsampledTraceParent :: Test -shouldDecodeUnsampledTraceParent = +shouldDecodeValidTraceParentWithRandomTraceId :: Test +shouldDecodeValidTraceParentWithRandomTraceId = let actual = W3CTraceContext.decode + "00-1234567890abcdeffedcba0987654321-24680bdf13579abc-03" + Nothing + expected = + sampledWithRandomTraceIdWithoutTraceState + "1234567890abcdeffedcba0987654321" + "24680bdf13579abc" + in + TestCase $ do + assertEqual "W3C Trace Context" expected actual + + +shouldDecodeUnsampledTraceParentWithoutRandomTraceId :: Test +shouldDecodeUnsampledTraceParentWithoutRandomTraceId = + let + actual = + W3CTraceContext.decode "00-1234567890abcdeffedcba0987654321-24680bdf13579abc-00" Nothing expected = - unsampledWithoutTraceState + unsampledNoRandomTraceIdWithoutTraceState "1234567890abcdeffedcba0987654321" "24680bdf13579abc" in @@ -222,6 +256,22 @@ assertEqual "W3C Trace Context" expected actual +shouldDecodeUnsampledTraceParentWithRandomTraceId :: Test +shouldDecodeUnsampledTraceParentWithRandomTraceId = + let + actual = + W3CTraceContext.decode + "00-1234567890abcdeffedcba0987654321-24680bdf13579abc-02" + Nothing + expected = + unsampledWithRandomTraceIdWithoutTraceState + "1234567890abcdeffedcba0987654321" + "24680bdf13579abc" + in + TestCase $ do + assertEqual "W3C Trace Context" expected actual + + shouldDecodeKnownPartsFromHigherVersionTraceParent :: Test shouldDecodeKnownPartsFromHigherVersionTraceParent = let @@ -230,7 +280,7 @@ "01-1234567890abcdeffedcba0987654321-24680bdf13579abc-01-beep-boop" Nothing expected = - sampledWithoutTraceState + sampledNoRandomTraceIdWithoutTraceState "1234567890abcdeffedcba0987654321" "24680bdf13579abc" in @@ -548,6 +598,7 @@ , parentId = "234123567890abcd" , flags = Flags { sampled = True + , randomTraceId = True } } , traceState = TraceState @@ -564,6 +615,33 @@ assertEqual "W3C Trace Context" expected actual +shouldInheritUnsetRandomTraceIdFlag :: Test +shouldInheritUnsetRandomTraceIdFlag = + let + initialW3cCtx = withoutRandomTraceId defaultW3cCtx + + actualW3CTraceContext = + W3CTraceContext.inheritFrom + initialW3cCtx + "5a6b7c8d9ef13402" + "234123567890abcd" + actualTraceParent = W3CTraceContext.traceParent actualW3CTraceContext + + expectedTraceParent = + TraceParent + { version = 0 + , traceId = "1234567890abcdeffedcba0987654321" + , parentId = "234123567890abcd" + , flags = Flags + { sampled = True + , randomTraceId = False + } + } + in + TestCase $ do + assertEqual "traceparent" expectedTraceParent actualTraceParent + + shouldInheritForSuppressed :: Test shouldInheritForSuppressed = let @@ -591,6 +669,7 @@ , parentId = "234123567890abcd" , flags = Flags { sampled = False + , randomTraceId = True } } , traceState = TraceState @@ -620,6 +699,7 @@ , parentId = "345fcb9140c8a6b9" , flags = Flags { sampled = True + , randomTraceId = True } } , traceState = TraceState @@ -652,6 +732,7 @@ , parentId = "345fcb9140c8a6b9" , flags = Flags { sampled = False + , randomTraceId = True } } , traceState = TraceState @@ -665,8 +746,8 @@ assertEqual "W3C Trace Context" expected actual -shouldEncodeToHeaders :: Test -shouldEncodeToHeaders = +shouldEncodeToHeadersSampledWithRandomTraceId :: Test +shouldEncodeToHeadersSampledWithRandomTraceId = let actual = W3CTraceContext.toHeaders $ @@ -682,7 +763,7 @@ expected = [ ( "traceparent" - , "00-1234567890abcdeffedcba0987654321-24680bdf13579abc-01" + , "00-1234567890abcdeffedcba0987654321-24680bdf13579abc-03" ) , ( "tracestate" , "in=fa2375d711a4ca0f;02468acefdb97531,congo=ucfJifl5GOE,rojo=00f067aa0ba902b7" @@ -693,11 +774,55 @@ assertEqual "W3C Trace Context Headers" expected actual +shouldEncodeToHeadersUnsampledWithRandomTraceId :: Test +shouldEncodeToHeadersUnsampledWithRandomTraceId = + let + actual = W3CTraceContext.toHeaders $ unsampled defaultW3cCtx + expected = + [ ( "traceparent" + , "00-1234567890abcdeffedcba0987654321-24680bdf13579abc-02" + ) + ] + in + TestCase $ do + assertEqual "W3C Trace Context Headers" expected actual + + +shouldEncodeToHeadersSampledWithoutRandomTraceId :: Test +shouldEncodeToHeadersSampledWithoutRandomTraceId = + let + actual = W3CTraceContext.toHeaders $ withoutRandomTraceId defaultW3cCtx + expected = + [ ( "traceparent" + , "00-1234567890abcdeffedcba0987654321-24680bdf13579abc-01" + ) + ] + in + TestCase $ do + assertEqual "W3C Trace Context Headers" expected actual + + +shouldEncodeToHeadersUnsampledWithoutRandomTraceId :: Test +shouldEncodeToHeadersUnsampledWithoutRandomTraceId = + let + actual = W3CTraceContext.toHeaders $ + unsampled $ + withoutRandomTraceId defaultW3cCtx + expected = + [ ( "traceparent" + , "00-1234567890abcdeffedcba0987654321-24680bdf13579abc-00" + ) + ] + in + TestCase $ do + assertEqual "W3C Trace Context Headers" expected actual + + shouldPadShortIds :: Test shouldPadShortIds = let Just w3cCtx = - (sampledWithoutTraceState + (sampledNoRandomTraceIdWithoutTraceState "1234" "5678") actual = @@ -729,7 +854,7 @@ shouldLimitLongIds = let Just w3cCtx = - (sampledWithoutTraceState + (sampledNoRandomTraceIdWithoutTraceState "fedcba9876543210abcdef0123456789fffff" "112233445566778899") actual = @@ -775,8 +900,8 @@ assertEqual "W3C Trace Context Headers" expected actual -sampledWithoutTraceState :: String -> String -> Maybe W3CTraceContext -sampledWithoutTraceState tId pId = +sampledWithRandomTraceIdWithoutTraceState :: String -> String -> Maybe W3CTraceContext +sampledWithRandomTraceIdWithoutTraceState tId pId = Just $ W3CTraceContext { traceParent = TraceParent @@ -785,6 +910,7 @@ , parentId = Id.fromString pId , flags = Flags { sampled = True + , randomTraceId = True } } , traceState = TraceState @@ -795,22 +921,57 @@ } -unsampledWithoutTraceState :: String -> String -> Maybe W3CTraceContext -unsampledWithoutTraceState tId pId = - unsampled $ sampledWithoutTraceState tId pId +sampledNoRandomTraceIdWithoutTraceState :: String -> String -> Maybe W3CTraceContext +sampledNoRandomTraceIdWithoutTraceState tId pId = + withoutRandomTraceIdM $ sampledWithRandomTraceIdWithoutTraceState tId pId -unsampled :: Maybe W3CTraceContext -> Maybe W3CTraceContext -unsampled mW3cCtx = +unsampledWithRandomTraceIdWithoutTraceState :: String -> String -> Maybe W3CTraceContext +unsampledWithRandomTraceIdWithoutTraceState tId pId = + unsampledM $ sampledWithRandomTraceIdWithoutTraceState tId pId + + +unsampledNoRandomTraceIdWithoutTraceState :: String -> String -> Maybe W3CTraceContext +unsampledNoRandomTraceIdWithoutTraceState tId pId = + unsampledM $ sampledNoRandomTraceIdWithoutTraceState tId pId + + +unsampledM :: Maybe W3CTraceContext -> Maybe W3CTraceContext +unsampledM mW3cCtx = let Just w3cCtx = mW3cCtx + in + Just $ unsampled w3cCtx + + +unsampled :: W3CTraceContext -> W3CTraceContext +unsampled w3cCtx = + let tp = traceParent w3cCtx fl = flags tp unsampledTp = tp { flags = fl { sampled = False } } in - Just $ w3cCtx { traceParent = unsampledTp } + w3cCtx { traceParent = unsampledTp } +withoutRandomTraceIdM :: Maybe W3CTraceContext -> Maybe W3CTraceContext +withoutRandomTraceIdM mW3cCtx = + let + Just w3cCtx = mW3cCtx + in + Just $ withoutRandomTraceId w3cCtx + + +withoutRandomTraceId :: W3CTraceContext -> W3CTraceContext +withoutRandomTraceId w3cCtx = + let + tp = traceParent w3cCtx + fl = flags tp + noRandomTraceIdTp = tp { flags = fl { randomTraceId = False } } + in + w3cCtx { traceParent = noRandomTraceIdTp } + + parseAndExtractTraceState :: Maybe String -> TraceState parseAndExtractTraceState traceStateHeader = let @@ -847,6 +1008,15 @@ , parentId = "24680bdf13579abc" , flags = Flags { sampled = True + , randomTraceId = True } + } + + +defaultW3cCtx :: W3CTraceContext +defaultW3cCtx = + W3CTraceContext + { traceParent = defaultTraceParent + , traceState = W3CTraceContext.emptyTraceState }