instana-haskell-trace-sdk 0.9.0.0 → 0.10.0.0
raw patch · 22 files changed
+722/−169 lines, 22 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- CHANGELOG.md +4/−1
- CONTRIBUTING.md +0/−1
- README.md +1/−1
- instana-haskell-trace-sdk.cabal +3/−1
- src/Instana/SDK/Internal/W3CTraceContext.hs +24/−7
- test/agent-stub/Instana/SDK/AgentStub/Config.hs +15/−4
- test/agent-stub/Instana/SDK/AgentStub/Server.hs +4/−14
- test/apps/downstream-target/Main.hs +1/−0
- test/apps/wai-with-middleware/Main.hs +16/−9
- test/apps/wai/Main.hs +17/−5
- test/integration/Instana/SDK/IntegrationTest/CustomSecrets.hs +8/−1
- test/integration/Instana/SDK/IntegrationTest/ExtraHttpHeaders.hs +0/−1
- test/integration/Instana/SDK/IntegrationTest/HttpTracing.hs +19/−4
- test/integration/Instana/SDK/IntegrationTest/Metrics.hs +0/−4
- test/integration/Instana/SDK/IntegrationTest/Runner.hs +9/−2
- test/integration/Instana/SDK/IntegrationTest/SpecCompliance.hs +293/−73
- test/integration/Instana/SDK/IntegrationTest/Suite.hs +20/−6
- test/integration/Instana/SDK/IntegrationTest/TestSuites.hs +42/−8
- test/integration/Instana/SDK/IntegrationTest/WaiMiddleware.hs +1/−1
- test/shared/Instana/SDK/AgentStub/TraceRequest.hs +48/−0
- test/unit/Instana/SDK/Internal/SpanStackTest.hs +1/−0
- test/unit/Instana/SDK/Internal/W3CTraceContextTest.hs +196/−26
CHANGELOG.md view
@@ -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
CONTRIBUTING.md view
@@ -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.
README.md view
@@ -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:
instana-haskell-trace-sdk.cabal view
@@ -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 <https://github.com/instana/haskell-trace-sdk#readme> 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
src/Instana/SDK/Internal/W3CTraceContext.hs view
@@ -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.
test/agent-stub/Instana/SDK/AgentStub/Config.hs view
@@ -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 []
test/agent-stub/Instana/SDK/AgentStub/Server.hs view
@@ -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
test/apps/downstream-target/Main.hs view
@@ -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
test/apps/wai-with-middleware/Main.hs view
@@ -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")+ ] }
test/apps/wai/Main.hs view
@@ -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")+ ] }
test/integration/Instana/SDK/IntegrationTest/CustomSecrets.hs view
@@ -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=<redacted>&"+ ++ "MYPASSWORD=abc&"+ ++ "this-will-be-obscured-by-the-regex-matcher=<redacted>&"+ ++ "secret=yes&"+ ++ "not-hidden=value" :: String+ ) , "status" .= (200 :: Int) ] )
test/integration/Instana/SDK/IntegrationTest/ExtraHttpHeaders.hs view
@@ -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=<redacted>" :: 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)
test/integration/Instana/SDK/IntegrationTest/HttpTracing.hs view
@@ -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=<redacted>&MYPASSWORD=<redacted>&another-query-param=zzz1&secret=<redacted>" :: 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=<redacted>" :: 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) ] )
test/integration/Instana/SDK/IntegrationTest/Metrics.hs view
@@ -49,10 +49,6 @@ "arguments" "" (EntityDataRequest.arguments entityData)- , assertLabelIs- "sensorVersion"- "0.9.0.0"- (EntityDataRequest.sensorVersion entityData) , assertCounterSatisfies "startTime" (1545570995405 <)
test/integration/Instana/SDK/IntegrationTest/Runner.hs view
@@ -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
test/integration/Instana/SDK/IntegrationTest/SpecCompliance.hs view
@@ -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=<redacted>" :: 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 ::
test/integration/Instana/SDK/IntegrationTest/Suite.hs view
@@ -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
test/integration/Instana/SDK/IntegrationTest/TestSuites.hs view
@@ -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 ]
test/integration/Instana/SDK/IntegrationTest/WaiMiddleware.hs view
@@ -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=<redacted>" :: String)+ , "params" .= ("some=query¶meters=1" :: String) , "status" .= (200 :: Int) ] )
@@ -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
test/unit/Instana/SDK/Internal/SpanStackTest.hs view
@@ -429,6 +429,7 @@ , parentId = "span-id" , flags = Flags { sampled = False+ , randomTraceId = False } } , traceState = TraceState
test/unit/Instana/SDK/Internal/W3CTraceContextTest.hs view
@@ -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 }