instana-haskell-trace-sdk 0.6.2.0 → 0.7.0.0

raw patch · 39 files changed

+4092/−602 lines, 39 filesdep +arraydep +vectorPVP ok

version bump matches the API change (PVP)

Dependencies added: array, vector

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−1
• CONTRIBUTING.md +4/−4
• README.md +7/−7
• instana-haskell-trace-sdk.cabal +15/−3
• src/Instana/SDK/Config.hs +4/−7
• src/Instana/SDK/Internal/Config.hs +46/−21
• src/Instana/SDK/Internal/Id.hs +72/−18
• src/Instana/SDK/Internal/Logging.hs +2/−1
• src/Instana/SDK/Internal/SpanStack.hs +55/−31
• src/Instana/SDK/Internal/Util.hs +34/−0
• src/Instana/SDK/Internal/W3CTraceContext.hs +502/−0
• src/Instana/SDK/Internal/WireSpan.hs +22/−1
• src/Instana/SDK/Internal/Worker.hs +23/−0
• src/Instana/SDK/SDK.hs +602/−272
• src/Instana/SDK/Span/EntrySpan.hs +55/−7
• src/Instana/SDK/Span/ExitSpan.hs +25/−13
• src/Instana/SDK/Span/NonRootEntry.hs +35/−13
• src/Instana/SDK/Span/RootEntry.hs +16/−4
• src/Instana/SDK/Span/Span.hs +57/−9
• src/Instana/SDK/TracingHeaders.hs +70/−0
• test/integration/Instana/SDK/IntegrationTest/BracketApi.hs +11/−7
• test/integration/Instana/SDK/IntegrationTest/HUnitExtra.hs +37/−16
• test/integration/Instana/SDK/IntegrationTest/HttpTracing.hs +20/−16
• test/integration/Instana/SDK/IntegrationTest/LowLevelApi.hs +10/−6
• test/integration/Instana/SDK/IntegrationTest/Metrics.hs +1/−1
• test/integration/Instana/SDK/IntegrationTest/Runner.hs +86/−23
• test/integration/Instana/SDK/IntegrationTest/ServiceName.hs +8/−4
• test/integration/Instana/SDK/IntegrationTest/SpecCompliance.hs +1041/−0
• test/integration/Instana/SDK/IntegrationTest/Suite.hs +18/−10
• test/integration/Instana/SDK/IntegrationTest/TestSuites.hs +125/−47
• test/integration/Instana/SDK/IntegrationTest/WaiMiddleware.hs +13/−9
• test/integration/Main.hs +39/−1
• test/shared/Instana/SDK/AgentStub/TraceRequest.hs +31/−0
• test/unit/Instana/SDK/Internal/LoggingTest.hs +97/−24
• test/unit/Instana/SDK/Internal/SpanStackTest.hs +45/−20
• test/unit/Instana/SDK/Internal/SpanTest.hs +1/−0
• test/unit/Instana/SDK/Internal/W3CTraceContextTest.hs +721/−0
• test/unit/Instana/SDK/TracingHeadersTest.hs +135/−6
• test/unit/Main.hs +2/−0

@@ -1,11 +1,15 @@ # Changelog for instana-haskell-trace-sdk +## 0.7.00+- Add support for W3C trace context.+- Fix: Interprete log levels provided via `INSTANA_LOG_LEVEL` and `INSTANA_LOG_LEVEL_STDOUT` case insensitive.+ ## 0.6.2.0 - Fix: Ignore incoming X-INSTANA-T/-S if website monitoring correlation data is present. - Add support for X-INSTANA-SYNTHETIC  ## 0.6.1.0-- Fix: Capture HTTP status code in `postProcessHttpRespons` even if an the currently active span is an exit.+- Fix: Capture HTTP status code in `postProcessHttpRespons` even if the currently active span is an exit.  ## 0.6.0.0 - Fix: Pass span ID of exit span downstream with X-INSTANA-S instead of the entry span's span ID.

@@ -70,8 +70,8 @@ * Wait for the CI build for branch main. * Build the package with stack and upload it to Hackage:     * `stack haddock && stack sdist && stack upload .`+    * Checkt that the package version is available on  <http://hackage.haskell.org/package/instana-haskell-trace-sdk>.+    * Run `bin/build-and-upload-docs.sh` to upload the haddock documentation. -Actually, the Hackage server should build the haddock docs after the package has been uploaded and add it to the package version. You can check if this has worked - if the individual modules on <http://hackage.haskell.org/package/instana-haskell-trace-sdk> are links to the documentation, it worked. Legend has it that this takes a few minutes - you could theoretically wait to see if the docs show up. Most of the times this does not actually work for reasons unknown. In these cases you can build the docs manually in the format Hackage expects and upload them for an already published package version by running-```-bin/build-and-upload-docs.sh $YOUR_HACKAGE_USER-```+Legend has it that the Hackage server should build the haddock docs after the package has been uploaded and add it to the package version. You could check if this has worked - if the individual modules on <http://hackage.haskell.org/package/instana-haskell-trace-sdk> are links to the documentation, it worked. Allegedly, this takes a few minutes. In fact, this has never worked once, for reasons unknown. The script `bin/build-and-upload-docs.sh` takes care of that.+

@@ -20,7 +20,7 @@  ``` extra-deps:-- instana-haskell-trace-sdk-0.6.2.0+- instana-haskell-trace-sdk-0.7.0.0 ```  Depending on the stack resolver you use, you might also need to add `aeson-extra` to your extra-deps:@@ -125,7 +125,7 @@  #### Trace HTTP Entries Automatically -You can let the SDK automatically create entry spans for all incoming HTTP requests in a WAI application by using it as a WAI middleware plug-in. Note that exit spans still need to be created manually via the `withHttpExit` or `startHttpExit`/`completeExit` functions (see below).+You can let the SDK automatically create entry spans for all incoming HTTP requests in a WAI application by using it as a WAI middleware plug-in. Instana tracing headers as well as W3C trace context headers are automatically taken into account by the plug-in. Note that exit spans still need to be created manually via the `withHttpExit` or `startHttpExit`/`completeExit` functions (see below).  The middleware plug-in will also add an additional HTTP response header (`Server-Timing`) to HTTP responses. This header enables website monitoring back end correlation. @@ -142,10 +142,10 @@  * `withRootEntry`: Creates an entry span that is the root of a trace (it has no parent span). * `withEntry`: Creates an entry span that has a parent span.-* `withHttpEntry`: A convenience function that examines an incoming HTTP request for Instana tracing headers and creates an entry span. It will automatically add the correct metadata to the span. Note that you do not need to handle incoming HTTP requests at all when using the Instana WAI middleware plug-in (see above).-* `withHttpEntry_`: A variant of `withHttpEntry` with a more general type signature, but less features. It will automatically continue the trace from incoming headers just like `withHttpEntry` does, but it will not capture the status code of the HTTP response or add the response header for website monitoring back end correlation (Server-Timing). It is recommended to use `withHttpEntry` instead of this function, if possible. Alternatively, you can also call `postProcessHttpResponse` inside the `withHttpEntry_` block to cover the two missing features mentioned above. Note that you do not need to handle incoming HTTP requests at all when using the Instana WAI middleware plug-in.+* `withHttpEntry`: A convenience function that examines an incoming HTTP request for Instana tracing headers or W3C trace context headers and creates an entry span. It will automatically add the correct metadata to the span. Note that you do not need to handle incoming HTTP requests at all when using the Instana WAI middleware plug-in (see above).+* `withHttpEntry_`: A variant of `withHttpEntry` with a more general type signature, but less features. It will automatically continue the trace from incoming headers (Instana headers or W3C trace context) just like `withHttpEntry` does, but it will not capture the status code of the HTTP response or add the response header for website monitoring back end correlation (Server-Timing). It is recommended to use `withHttpEntry` instead of this function, if possible. Alternatively, you can also call `postProcessHttpResponse` inside the `withHttpEntry_` block to cover the two missing features mentioned above. Note that you do not need to handle incoming HTTP requests at all when using the Instana WAI middleware plug-in. * `withExit`: Creates an exit span. This can only be called inside a `withRootEntry` or an `withEntry` call, as an exit span needs an entry span as its parent.-* `withHttpExit`: Creates an exit span for a given HTTP client request. It will automatically add the correct metadata to the span so it should be preferred to `withExit` when tracing outgoing HTTP requests. It will also add HTTP headers to the request to propagate the trace context downstream.+* `withHttpExit`: Creates an exit span for a given HTTP client request. It will automatically add the correct metadata to the span so it should be preferred to `withExit` when tracing outgoing HTTP requests. It will also add Instana tracing HTTP headers as well as W3C trace context HTTP headers HTTP to the request to propagate the trace context downstream. * `postProcessHttpResponse`: Processes the response of an HTTP entry. This function needs be called while the HTTP entry span is still active. It can be used inside a `withHttpEntry_` block or between `startHttpEntry` and `completeEntry`. This function accomplishes two things: It captures the HTTP status code from the response and adds it as an annotation to the currently active span. It also adds an additional HTTP response header (Server-Timing) to the given HTTP response that enables website monitoring back end correlation. Client code should rarely have the need to call this directly. Instead, capture incoming HTTP requests with `withHttpEntry`, which does both of these things automatically.  #### Low Level API/Explicit Start And Complete@@ -190,8 +190,8 @@  #### Logging Related Environment Variables -* `INSTANA_LOG_LEVEL`: Sets the log level for the SDK's log file. The log file will be written to the system's temporary directory (in particular, whatever `System.Directory.getTemporaryDirectory` returns) as `instana-haskell-sdk.{pid}.log`.-* `INSTANA_LOG_LEVEL_STDOUT`: Sets the level for emitting log messages to stdout.+* `INSTANA_LOG_LEVEL`: Sets the log level for the SDK's log file. The log file will be written to the system's temporary directory (in particular, whatever `System.Directory.getTemporaryDirectory` returns) as `instana-haskell-sdk.{pid}.log`. All [log priorities from hslogger](http://hackage.haskell.org/package/hslogger-1.3.1.0/docs/System-Log-Logger.html#t:Priority) can be used, case insensitive.+* `INSTANA_LOG_LEVEL_STDOUT`: Sets the level for emitting log messages to stdout. All [log priorities from hslogger](http://hackage.haskell.org/package/hslogger-1.3.1.0/docs/System-Log-Logger.html#t:Priority) can be used, case insensitive. * `INSTANA_OVERRIDE_HSLOGGER_ROOT_HANDLER`: Controls whether the SDK sets an hslogger at the root logger level, see below.  #### When To Set `INSTANA_OVERRIDE_HSLOGGER_ROOT_HANDLER`

@@ -1,5 +1,5 @@ name:           instana-haskell-trace-sdk-version:        0.6.2.0+version:        0.7.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/@@ -92,7 +92,6 @@       Instana.SDK.Internal.Command       Instana.SDK.Internal.Config       Instana.SDK.Internal.Context-      Instana.SDK.Internal.WireSpan       Instana.SDK.Internal.Id       Instana.SDK.Internal.Logging       Instana.SDK.Internal.Metrics.Collector@@ -101,10 +100,12 @@       Instana.SDK.Internal.Metrics.Sample       Instana.SDK.Internal.Retry       Instana.SDK.Internal.Secrets-      Instana.SDK.Internal.SpanStack       Instana.SDK.Internal.ServerTiming+      Instana.SDK.Internal.SpanStack       Instana.SDK.Internal.URL       Instana.SDK.Internal.Util+      Instana.SDK.Internal.W3CTraceContext+      Instana.SDK.Internal.WireSpan       Instana.SDK.Internal.Worker       Instana.Wai.Middleware.Entry.Internal       Paths_instana_haskell_trace_sdk@@ -154,6 +155,7 @@     , aeson     , aeson-extra     , bytestring+    , case-insensitive     , directory     , ekg-core     , http-types@@ -166,6 +168,7 @@     , scientific     , text     , unordered-containers+    , wai   other-modules:       -- the actual tests       Instana.SDK.Internal.AgentConnection.SchedFileTest@@ -178,6 +181,7 @@       Instana.SDK.Internal.ServerTimingTest       Instana.SDK.Internal.SpanStackTest       Instana.SDK.Internal.SpanTest+      Instana.SDK.Internal.W3CTraceContextTest       Instana.SDK.TracingHeadersTest       -- modules under test       Instana.SDK.Internal.Config@@ -192,6 +196,7 @@       Instana.SDK.Span.SimpleSpan       Instana.SDK.Span.Span       Instana.SDK.TracingHeaders+      Instana.SDK.Internal.W3CTraceContext       -- dependencies of modules under test       Instana.SDK.Config       Instana.SDK.Internal.Metrics.Sample@@ -258,7 +263,10 @@   build-depends:       base >=4.7 && <5     , aeson+    , array     , bytestring+    , case-insensitive+    , directory     , exceptions     , hslogger     , HUnit@@ -266,10 +274,13 @@     , http-types     , instana-haskell-trace-sdk     , process+    , regex-base+    , regex-tdfa     , retry     , text     , unix     , unordered-containers+    , vector   other-modules:       Instana.SDK.AgentStub.DiscoveryRequest     , Instana.SDK.AgentStub.EntityDataRequest@@ -284,6 +295,7 @@     , Instana.SDK.IntegrationTest.Metrics     , Instana.SDK.IntegrationTest.Runner     , Instana.SDK.IntegrationTest.ServiceName+    , Instana.SDK.IntegrationTest.SpecCompliance     , Instana.SDK.IntegrationTest.Suite     , Instana.SDK.IntegrationTest.TestHelper     , Instana.SDK.IntegrationTest.TestSuites

@@ -5,14 +5,8 @@ -} module Instana.SDK.Config   -- Maintenance note: accessor functions need to be reexported in SDK.hs-  ( Config-  , agentHost-  , agentPort+  ( Config(..)   , defaultConfig-  , forceTransmissionAfter-  , forceTransmissionStartingAt-  , maxBufferedSpans-  , serviceName   ) where  @@ -42,6 +36,8 @@     -- buffering excessive amounts of spans. It must be larger than     -- forceTransmissionStartingAt.   , maxBufferedSpans            :: Maybe Int+    -- | Disables continuing traces from W3C trace context (traceparent header).+  , disableW3cTraceCorrelation  :: Bool   } deriving (Eq, Generic)  @@ -58,5 +54,6 @@     , forceTransmissionAfter = Nothing     , forceTransmissionStartingAt = Nothing     , maxBufferedSpans = Nothing+    , disableW3cTraceCorrelation = False     } 

@@ -17,7 +17,7 @@   import           Control.Applicative ((<|>))-import           Data.Maybe          (fromMaybe)+import           Data.Maybe          (fromMaybe, isJust) import           GHC.Generics import           System.Environment  (lookupEnv) import           Text.Read           (readMaybe)@@ -31,11 +31,21 @@ agentHostKey = "INSTANA_AGENT_HOST"  +-- |Default agent host/IP+defaultAgentHost :: String+defaultAgentHost = "127.0.0.1"++ -- |Environment variable for the agent port agentPortKey :: String agentPortKey = "INSTANA_AGENT_PORT"  +-- |Default agent port+defaultAgentPort :: Int+defaultAgentPort = 42699++ -- |Environment variable for the service name override. serviceNameKey :: String serviceNameKey = "INSTANA_SERVICE_NAME"@@ -46,39 +56,40 @@ forceTransmissionAfterKey = "INSTANA_FORCE_TRANSMISSION_STARTING_AFTER"  +-- |Default force-transmission-after setting+defaultForceTransmissionAfter :: Int+defaultForceTransmissionAfter = 1000++ -- |Environment variable for the force-transmision-at setting forceTransmissionStartingAtKey :: String forceTransmissionStartingAtKey = "INSTANA_FORCE_TRANSMISSION_STARTING_AT"  +-- |Default force-transmission-at setting+defaultForceTransmissionStartingAt :: Int+defaultForceTransmissionStartingAt = 500++ -- |Environment variable for the max-buffered-spans setting maxBufferedSpansKey :: String maxBufferedSpansKey = "INSTANA_MAX_BUFFERED_SPANS"  --- |Default agent host/IP-defaultAgentHost :: String-defaultAgentHost = "127.0.0.1"----- |Default agent port-defaultAgentPort :: Int-defaultAgentPort = 42699----- |Default force-transmission-after setting-defaultForceTransmissionAfter :: Int-defaultForceTransmissionAfter = 1000+-- |Default max-buffered-spans setting+defaultMaxBufferedSpans :: Int+defaultMaxBufferedSpans = 1000  --- |Default force-transmission-at setting-defaultForceTransmissionStartingAt :: Int-defaultForceTransmissionStartingAt = 500+-- |Environment variable to disable trace correlation via W3C trace context+-- headers.+disableW3cTraceCorrelationKey :: String+disableW3cTraceCorrelationKey = "INSTANA_DISABLE_W3C_TRACE_CORRELATION"  --- |Default max-buffered-spans setting-defaultMaxBufferedSpans :: Int-defaultMaxBufferedSpans = 1000+-- |Default value for disable W3C trace correlation.+defaultDisableW3cTraceCorrelation :: Bool+defaultDisableW3cTraceCorrelation = False   -- |The config after evaluating and merging user provided config, environment@@ -90,6 +101,7 @@   , forceTransmissionAfter      :: Int   , forceTransmissionStartingAt :: Int   , maxBufferedSpans            :: Int+  , disableW3cTraceCorrelation  :: Bool   } deriving (Eq, Generic, Show)  @@ -101,6 +113,7 @@   -> Int   -> Int   -> Int+  -> Bool   -> FinalConfig mkFinalConfig   agentHost_@@ -108,7 +121,8 @@   serviceName_   forceTransmissionAfter_   forceTransmissionStartingAt_-  maxBufferedSpans_ =+  maxBufferedSpans_+  disableW3cTraceCorrelation_ =   FinalConfig     { agentHost = agentHost_     , agentPort = agentPort_@@ -116,6 +130,7 @@     , forceTransmissionAfter = forceTransmissionAfter_     , forceTransmissionStartingAt = forceTransmissionStartingAt_     , maxBufferedSpans = maxBufferedSpans_+    , disableW3cTraceCorrelation = disableW3cTraceCorrelation_     }  @@ -128,6 +143,7 @@   forceTransmissionAfterEnv <- lookupEnv forceTransmissionAfterKey   forceTransmissionStartingAtEnv <- lookupEnv forceTransmissionStartingAtKey   maxBufferedSpansEnv <- lookupEnv maxBufferedSpansKey+  disableW3cTraceCorrelationEnv <- lookupEnv disableW3cTraceCorrelationKey   let     -- parse numeric config values via readMaybe to Int if they were set,     -- otherwise they remain Nothing@@ -137,6 +153,7 @@     forceTransmissionStartingAtParsed =       forceTransmissionStartingAtEnv >>= readMaybe     maxBufferedSpansParsed = maxBufferedSpansEnv >>= readMaybe+    disableW3cTraceCorrelationParsed = isJust disableW3cTraceCorrelationEnv   return $     Config.defaultConfig       { Config.agentHost = agentHostEnv@@ -145,6 +162,7 @@       , Config.forceTransmissionAfter = forceTransmissionAfterParsed       , Config.forceTransmissionStartingAt = forceTransmissionStartingAtParsed       , Config.maxBufferedSpans = maxBufferedSpansParsed+      , Config.disableW3cTraceCorrelation = disableW3cTraceCorrelationParsed       }  @@ -177,6 +195,9 @@        fromMaybe          defaultMaxBufferedSpans          (Config.maxBufferedSpans config)+   , disableW3cTraceCorrelation =+       defaultDisableW3cTraceCorrelation ||+       (Config.disableW3cTraceCorrelation config)    }  @@ -203,6 +224,10 @@       , Config.maxBufferedSpans =           (Config.maxBufferedSpans userConfig) <|>           (Config.maxBufferedSpans configFromEnv)+      , Config.disableW3cTraceCorrelation =+          (Config.disableW3cTraceCorrelation userConfig) ||+          (Config.disableW3cTraceCorrelation configFromEnv)       }   in     applyDefaults merged+

@@ -9,8 +9,13 @@    ( Id    , generate    , fromString+   , fromText+   , longOrShortTraceId+   , longTraceId    , toByteString+   , toByteStringUnshortened    , toString+   , toStringUnshortened    , toText    -- exposed for testing purposes    , createFromIntsForTest@@ -18,19 +23,21 @@    where  -import           Control.Monad         (replicateM)-import           Data.Aeson            (FromJSON, ToJSON, Value)-import qualified Data.Aeson            as Aeson-import           Data.Aeson.Types      (Parser)-import qualified Data.ByteString.Char8 as BSC8-import qualified Data.String           (IsString (..))-import           Data.Text             (Text)-import qualified Data.Text             as T+import           Control.Monad             (replicateM)+import           Data.Aeson                (FromJSON, ToJSON, Value)+import qualified Data.Aeson                as Aeson+import           Data.Aeson.Types          (Parser)+import qualified Data.ByteString.Char8     as BSC8+import qualified Data.String               (IsString (..))+import           Data.Text                 (Text)+import qualified Data.Text                 as T import           GHC.Generics-import           Numeric               (showHex)-import qualified System.Random         as Random+import           Numeric                   (showHex)+import qualified System.Random             as Random +import           Instana.SDK.Internal.Util (leftPad) + -- |Represents an ID (trace ID, span ID). data Id =     -- |a representation of a 64 bit ID with just enough Int components to@@ -39,13 +46,16 @@     -- |a representation of a 64 bit ID as a plain string (used when     -- deserializing IDs, for example when reading HTTP headers)   | IdString String+    -- |a 16 character/64 bit ID that has been shortened from a longer original.+    -- The first component is the shortened ID, the second the is original ID.+  | ShortenedId String String   deriving (Eq, Generic, Show)   instance FromJSON Id where   parseJSON :: Value -> Parser Id   parseJSON = Aeson.withText "Id string" $-    \string -> return $ IdString $ (T.unpack string)+    \string -> return $ fromString $ (T.unpack string)   instance ToJSON Id where@@ -68,12 +78,6 @@     appendPaddedHex = flip ((++) . toPaddedHex)  -leftPad :: Int -> String -> String-leftPad digits s-  | length s < digits = replicate (digits - length s) '0' ++ s-  | otherwise         = s-- -- |Generates a new random ID. generate :: IO Id generate = do@@ -109,12 +113,55 @@         (reverse intComponents)     IdString string ->       string+    ShortenedId string _ ->+      string ++-- |Converts an ID into a String, using the unshortened value (in case this is a+-- ShortenedId).+toStringUnshortened :: Id -> String+toStringUnshortened theId =+  case theId of+    ShortenedId _ unshortened ->+      unshortened+    _ ->+      toString theId+++-- |Retrieves the original long trace ID as a string in case this ID has been+-- created by shortening a 128 bit trace ID, or Nothing otherwise.+longTraceId :: Id -> Maybe String+longTraceId theId =+  case theId of+    ShortenedId _ original -> Just original+    _                      -> Nothing+++-- |Retrieves the original long trace ID as a string in case this ID has been+-- created by shortening a 128 bit trace ID, or the full ID as a string+-- otherwise.+longOrShortTraceId :: Id -> String+longOrShortTraceId theId =+  case theId of+    ShortenedId _ original -> original+    _                      -> toString theId++ --- |Converts a string into an ID. fromString :: String -> Id-fromString = IdString+fromString =+  fromText . T.pack  +--- |Converts a Text into an ID.+fromText :: Text -> Id+fromText t =+  if T.length t > 16 then+    ShortenedId (T.unpack $ T.takeEnd 16 t) (T.unpack t)+  else+    IdString $ T.unpack t++ -- |Converts an ID into a Text toText :: Id -> Text toText =@@ -125,6 +172,13 @@ toByteString :: Id -> BSC8.ByteString toByteString =   BSC8.pack . toString+++-- |Converts an ID into a ByteString, providing the unshortened value (this+-- only makes a difference when this is a ShortenedId).+toByteStringUnshortened :: Id -> BSC8.ByteString+toByteStringUnshortened =+  BSC8.pack . toStringUnshortened   -- |Only exposed for testing, do not use this.

@@ -16,6 +16,7 @@  import           Control.Monad             (when) import           Data.Maybe                (catMaybes, isJust)+import qualified Data.Text                 as T import           System.Directory          (getTemporaryDirectory) import           System.Environment        (lookupEnv) import           System.IO                 (Handle, stdout)@@ -191,7 +192,7 @@ -- |Parses a string into a hslogger log level. parseLogLevel :: String -> Maybe Priority parseLogLevel logLevelStr =-  case logLevelStr of+  case (T.unpack $ T.toUpper $ T.pack logLevelStr) of     "DEBUG"     -> Just DEBUG     "INFO"      -> Just INFO     "NOTICE"    -> Just NOTICE

@@ -17,19 +17,22 @@   , push   , pushSuppress   , readTraceId+  , readW3cTraceContext   , suppress   ) where  import           GHC.Generics -import           Instana.SDK.Internal.Id    (Id)-import           Instana.SDK.Internal.Util  ((|>))-import           Instana.SDK.Span.EntrySpan (EntrySpan)-import qualified Instana.SDK.Span.EntrySpan as EntrySpan-import           Instana.SDK.Span.ExitSpan  (ExitSpan)-import           Instana.SDK.Span.Span      (Span (..), SpanKind (..))+import           Instana.SDK.Internal.Id              (Id)+import           Instana.SDK.Internal.Util            ((|>))+import           Instana.SDK.Internal.W3CTraceContext (W3CTraceContext)+import           Instana.SDK.Span.EntrySpan           (EntrySpan)+import qualified Instana.SDK.Span.EntrySpan           as EntrySpan+import           Instana.SDK.Span.ExitSpan            (ExitSpan)+import qualified Instana.SDK.Span.ExitSpan            as ExitSpan+import           Instana.SDK.Span.Span                (Span (..), SpanKind (..)) ---+ -- Implementation Note -- =================== --@@ -38,7 +41,7 @@ -- doing actual async IO, for example). Since Haskell's standard vehicle for -- concurrency (Control.Concurrent#forkIO and friends) uses green threads (and -- not OS level threads) doing multiple things in one thread at the same time is--- not very common, in fact I haven't seen it in the wild yet.+-- not very common, in fact, I haven't seen it in the wild yet. -- -- Under this assumptions there can be at most two current spans per thread, an -- entry and an exit. A new exit can only be started once the IO action related@@ -57,7 +60,7 @@     None     -- |Indicates that we are currently processing a request that had     -- X-INSTANA-L=0 set and that should not record any spans.-  | Suppressed+  | Suppressed W3CTraceContext     -- |Indicates that we are currently processing an entry.   | EntryOnly EntrySpan     -- |Indicates that currently an exit is in progress.@@ -80,9 +83,9 @@     |> push (Entry entrySpan)  -{-|Creates an span stack with a suppressed marker.+{-|Creates a span stack with a suppressed marker. -}-suppress :: SpanStack+suppress :: W3CTraceContext -> SpanStack suppress =   Suppressed @@ -97,19 +100,22 @@ {-|Checks if tracing is currently suppressed. -} isSuppressed :: SpanStack -> Bool-isSuppressed t =-  t == Suppressed+isSuppressed stack =+  case stack of+    Suppressed _ -> True+    _            -> False   {-|Pushes a span onto the stack. Invalid calls are ignored (like pushing an-exit onto an empty span or an entry span onto an already existing entry span.+exit onto an empty stack or an entry span onto an already existing entry span. -} push :: Span -> SpanStack -> SpanStack push (Entry entrySpan) None =   EntryOnly entrySpan -- a new incoming entry can lift the suppression, an exit can't-push (Entry entrySpan) Suppressed =+push (Entry entrySpan) (Suppressed _) =   EntryOnly entrySpan+-- pushing an exit child onto an entry parent is valid push (Exit exitSpan) (EntryOnly entrySpan) =   EntryAndExit entrySpan exitSpan -- ignore invalid calls/invalid state@@ -119,14 +125,18 @@  {-|Pushes a suppressed marker onto the stack. This is only valid if the span stack is currently empty, otherwise the span stack is returned unmodified.++When pushing the suppressed marker, the w3c trace context for the request in+progress must still be provided. -}-pushSuppress :: SpanStack -> SpanStack-pushSuppress None =-  Suppressed-pushSuppress Suppressed =-  Suppressed+pushSuppress :: W3CTraceContext -> SpanStack -> SpanStack+pushSuppress w3cTraceContext None =+  Suppressed w3cTraceContext+pushSuppress w3cTraceContext (Suppressed _) =+  -- this effectively overwrites/discards the previous W3C trace context+  Suppressed w3cTraceContext -- ignore invalid calls/invalid state-pushSuppress current =+pushSuppress _ current =   current  @@ -136,7 +146,7 @@ pop :: SpanStack -> (SpanStack, Maybe Span) pop None =   (None, Nothing)-pop Suppressed =+pop (Suppressed _) =   (None, Nothing) pop (EntryOnly entrySpan) =   (None, Just $ Entry entrySpan)@@ -154,14 +164,14 @@ popWhenMatches :: SpanKind -> SpanStack -> (SpanStack, Maybe Span, Maybe String) popWhenMatches _ None =   (None, Nothing, Nothing)-popWhenMatches EntryKind Suppressed =+popWhenMatches EntryKind (Suppressed _) =   -- This effectively unsuppresses - we started an entry that was suppressed and   -- now we are asked to complete this very entry, so the suppression is lifted   -- and we are back to a pristine state, ready to start the next entry when the   -- next request comes in.   (None, Nothing, Nothing)-popWhenMatches _ Suppressed =-  (Suppressed, Nothing, Nothing)+popWhenMatches _ (Suppressed w3cTraceContext)  =+  (Suppressed w3cTraceContext, Nothing, Nothing) popWhenMatches expectedKind stack =   case (expectedKind, peek stack) of     (EntryKind, Just (Entry _)) ->@@ -185,7 +195,7 @@ peek :: SpanStack -> Maybe Span peek None =   Nothing-peek Suppressed =+peek (Suppressed _) =   Nothing peek (EntryOnly entrySpan) =   Just $ Entry entrySpan@@ -198,7 +208,7 @@ readTraceId :: SpanStack -> Maybe Id readTraceId None =   Nothing-readTraceId Suppressed =+readTraceId (Suppressed _) =   Nothing readTraceId (EntryOnly entrySpan) =   Just $ EntrySpan.traceId entrySpan@@ -206,14 +216,28 @@   Just $ EntrySpan.traceId entrySpan  +{-|Reads the W3C trace context from the current span or suppression marker,+if any.+-}+readW3cTraceContext :: SpanStack -> Maybe W3CTraceContext+readW3cTraceContext None =+  Nothing+readW3cTraceContext (Suppressed w3cTraceContext) =+  Just w3cTraceContext+readW3cTraceContext (EntryOnly entrySpan) =+  EntrySpan.w3cTraceContext entrySpan+readW3cTraceContext (EntryAndExit _ exitSpan) =+  Just $ ExitSpan.w3cTraceContext exitSpan++ {-|Modifies the top element in place by applying the given function to it. This is a no op if the span stack is empty. -} mapTop :: (Span -> Span) -> SpanStack -> SpanStack mapTop _ None =   None-mapTop _ Suppressed =-  Suppressed+mapTop _ (Suppressed w3cTraceContext) =+  Suppressed w3cTraceContext mapTop fn stack =   let     (remainder, Just oldTop) = pop stack@@ -229,8 +253,8 @@ mapEntry :: (Span -> Span) -> SpanStack -> SpanStack mapEntry _ None =   None-mapEntry _ Suppressed =-  Suppressed+mapEntry _ (Suppressed w3cTraceContext) =+  Suppressed w3cTraceContext mapEntry fn (EntryOnly entrySpan) =   mapTop fn (EntryOnly entrySpan) mapEntry fn (EntryAndExit oldEntrySpan oldExitSpan) =

@@ -4,10 +4,44 @@ -} module Instana.SDK.Internal.Util   ( (|>)+  , leftPad+  , leftPadAndLimit+  , limit   ) where  +import qualified Data.Text as T++ -- |Elm-style function application. (|>) :: a -> (a -> b) -> b (|>) =   flip ($)+++-- |Prepends the character "0" to this string until it has the given length.+-- Otherwise the input is returned unmodified.+leftPad :: Int -> String -> String+leftPad digits s+  | length s < digits = replicate (digits - length s) '0' ++ s+  | otherwise         = s+++-- |If the given string is shorten than the requested length, the character "0"+-- is prepended to this string. If the given string is longer than the requested+-- length, the leading characters will be discarded to limit it to the requested+-- length. Otherwise the input is returned unmodified.+leftPadAndLimit :: Int -> String -> String+leftPadAndLimit digits s =+  leftPad digits s+  |> limit digits+++-- |If the given string is longer than the requested length, the leading+-- characters will be discarded to limit it to the requested length. Otherwise+-- the input is returned unmodified.+limit :: Int -> String -> String+limit digits s+  | length s > digits = T.unpack $ T.takeEnd digits $ T.pack s+  | otherwise         = s+

@@ -0,0 +1,502 @@+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE OverloadedStrings #-}+{-|+Module      : Instana.SDK.Span.W3CTraceContext+Description : Utility module for decoding and encoding the W3C Trace Context+              headers.+-}+module Instana.SDK.Internal.W3CTraceContext+    ( Flags(..)+    , InstanaKeyValuePair(..)+    , TraceParent(..)+    , TraceState(..)+    , W3CTraceContext(..)+    , createExitContextForSuppressed+    , decode+    , exitSpanContextFromIds+    , inheritFrom+    , inheritFromForSuppressed+    , initBogusContextForSuppressedRequest+    , toHeaders+    ) where+++import qualified Data.Bits                  as Bits+import qualified Data.ByteString.Char8      as BSC8+import qualified Data.List                  as List+import qualified Data.Maybe                 as Maybe+import           Data.Text                  (Text)+import qualified Data.Text                  as T+import           GHC.Generics+import qualified Network.HTTP.Types         as HTTPTypes+import           Numeric                    (readHex)++import           Instana.SDK.Internal.Id    (Id)+import qualified Instana.SDK.Internal.Id    as Id+import           Instana.SDK.Internal.Util  (leftPad, leftPadAndLimit)+import qualified Instana.SDK.TracingHeaders as TracingHeaders+++-- |A representation of the W3C trace context headers traceparent and+-- tracestate.+data W3CTraceContext = W3CTraceContext+  { traceParent :: TraceParent+  , traceState  :: TraceState+  } deriving (Eq, Generic, Show)+++-- |A representation of the W3C trace context header traceparent.+data TraceParent = TraceParent+  { version  :: Int+  , traceId  :: Id+  , parentId :: Id+  , flags    :: Flags+  } deriving (Eq, Generic, Show)+++-- |A representation of the flags part of the W3C trace context header+-- traceparent.+data Flags = Flags+  { sampled  :: Bool+  } deriving (Eq, Generic, Show)+++-- |A representation of the W3C trace context header tracestate.+data TraceState = TraceState+  { traceStateHead      :: Maybe Text+  , instanaKeyValuePair :: Maybe InstanaKeyValuePair+  , traceStateTail      :: Maybe Text+  } deriving (Eq, Generic, Show)+++-- |A representation of the Instana key-value pair W3C contained in the+-- tracestate header.+data InstanaKeyValuePair = InstanaKeyValuePair+  { instanaTraceId  :: Id+  , instanaParentId :: Id+  } deriving (Eq, Generic, Show)+++-- |Decodes the raw values of traceparent and tracestate to the parsed+-- representation of the W3C trace context. If the traceparent value is invalid,+-- Nothing will be returned.+decode :: String -> Maybe String -> Maybe W3CTraceContext+decode traceparentHeader tracestateHeader =+  let+    maybeTraceParent = decodeTraceParent traceparentHeader+  in+  case maybeTraceParent of+    Just tp ->+      Just $+        W3CTraceContext+        { traceParent = tp+        , traceState = decodeTraceState tracestateHeader+        }+    Nothing ->+      Nothing+++-- |Decodes the raw traceparent value. If the traceparent value is invalid,+-- Nothing will be returned.+decodeTraceParent :: String -> Maybe TraceParent+decodeTraceParent traceParentString =+  let+    traceParentText = T.pack traceParentString+    components = T.splitOn "-" traceParentText+  in+  if length components < 4+    then+      Nothing+    else+      decodeTraceParentComponents components+++-- |Decodes the individual traceparent fields. If any of them is invalid,+-- Nothing will be returned.+decodeTraceParentComponents :: [Text] -> Maybe TraceParent+decodeTraceParentComponents components =+  let+    rawVersion = components !! 0+    rawTraceId = components !! 1+    rawParentId = components !! 2+    rawFlags = components !! 3+  in+  case ( validVersion rawVersion+       , validTraceId rawTraceId+       , validParentId rawParentId+       , validFlags rawFlags) of+    (True, True, True, True) ->+      let+        tId = Id.fromText $ rawTraceId+        pId = Id.fromText $ rawParentId+        flagsReadResult = readHex $ T.unpack $ rawFlags+        flgs :: Maybe Integer+        flgs = Maybe.listToMaybe . map fst $ flagsReadResult+        smpld :: Bool+        smpld = case flgs of+          Just fl ->+            Bits.testBit fl 0+          Nothing ->+            False+      in+      Just $ TraceParent+        { version  = 0+        , traceId  = tId+        , parentId = pId+        , flags    = Flags+          { sampled = smpld+          }+        }+    _ ->+      Nothing+++-- |Checks if the version field of traceparent is valid.+validVersion :: Text -> Bool+validVersion rawVersion =+  T.length rawVersion == 2 &&+  onlyLowerCaseHex rawVersion &&+  not (T.all (\c -> c == 'f') rawVersion)+++-- |Checks if the trace ID field of traceparent is valid.+validTraceId :: Text -> Bool+validTraceId rawTraceId =+  T.length rawTraceId == 32 &&+  onlyLowerCaseHex rawTraceId &&+  not (T.all (\c -> c == '0') rawTraceId)+++-- |Checks if the parent ID field of traceparent is valid.+validParentId :: Text -> Bool+validParentId rawParentId =+  T.length rawParentId == 16 &&+  onlyLowerCaseHex rawParentId &&+  not (T.all (\c -> c == '0') rawParentId)+++-- |Checks if the flags field of traceparent is valid.+validFlags :: Text -> Bool+validFlags rawFlags =+  T.length rawFlags == 2 &&+  onlyLowerCaseHex rawFlags+++-- |Checks if the given text contains only lower case hex strings (0-9, a-f.+onlyLowerCaseHex :: Text -> Bool+onlyLowerCaseHex t =+  T.all (\c -> c `elem` (['0'..'9'] ++ ['a'..'f'])) t+++-- |Decodes the raw tracestate value.+decodeTraceState :: Maybe String -> TraceState+decodeTraceState maybeTraceStateString =+  case maybeTraceStateString of++    Just traceStateString ->+      decodeTraceState' traceStateString++    Nothing ->+      emptyTraceState+++-- |Decodes the raw tracestate value.+decodeTraceState' :: String -> TraceState+decodeTraceState' traceStateString =+  let+    traceStateText = T.strip $ T.pack traceStateString+  in+  if T.length traceStateText == 0+    then+      emptyTraceState+    else+      decodeNonEmptyTraceState traceStateText+++-- |Decodes the raw tracestate value.+decodeNonEmptyTraceState :: Text -> TraceState+decodeNonEmptyTraceState traceStateText =+  let+    keyValuePairs = map T.strip $ T.splitOn "," traceStateText+    inKvPairIndex =+      List.findIndex (\kvPairString ->+        let+          key = T.strip $ fst $ T.breakOn "=" kvPairString+        in+        key == "in"+      ) keyValuePairs++    (tsHead, inKvPair, tsTail) =+      case inKvPairIndex of+        Just idx ->+          let+            preIdx = take idx keyValuePairs+            tsHd =+              if null preIdx+                then Nothing+                else Just $ T.intercalate "," preIdx+            tsTl =+              if null postIdx+                then Nothing+                else Just $ T.intercalate "," postIdx+            postIdx = drop (idx + 1) keyValuePairs+          in+          ( tsHd+          , decodeInKeyValuePair $ keyValuePairs !! idx+          , tsTl+          )+        Nothing ->+          ( Just $ T.intercalate "," keyValuePairs+          , Nothing+          , Nothing+          )++  in+  TraceState+  { traceStateHead      = tsHead+  , instanaKeyValuePair = inKvPair+  , traceStateTail      = tsTail+  }+++-- |Decodes the Instana key value pair from the raw tracestate value.+decodeInKeyValuePair :: Text -> Maybe InstanaKeyValuePair+decodeInKeyValuePair inKvPairText =+  let+    value = T.strip $ T.drop 1 $ snd $ T.breakOn "=" inKvPairText+    (tIdRaw, pIdRaw) = T.breakOn ";" value+    (tId, pId) =+      ( T.strip tIdRaw+      , T.strip $ T.drop 1 $ pIdRaw+      )+  in+  if (T.length tId >= 16 && T.length pId >= 16) then+    Just InstanaKeyValuePair+      { instanaTraceId  = Id.fromText $ tId+      , instanaParentId = Id.fromText $ pId+      }+  else+    Nothing+++-- |Creates an empty trace state value.+emptyTraceState :: TraceState+emptyTraceState =+  TraceState+  { traceStateHead      = Nothing+  , instanaKeyValuePair = Nothing+  , traceStateTail      = Nothing+  }+++-- |Tests whether the given trace state represents an empty trace state.+isEmpty :: TraceState -> Bool+isEmpty ts =+  ts == TraceState+        { traceStateHead      = Nothing+        , instanaKeyValuePair = Nothing+        , traceStateTail      = Nothing+        }+++-- |Creates a new W3C trace context value for an outgoing HTTP request by+-- inheriting from the given parent context.+inheritFrom :: W3CTraceContext -> Id -> Id -> W3CTraceContext+inheritFrom parentW3cTraceContext exitSpanTraceId exitSpanSpanId =+  let+    parentTp = traceParent $ parentW3cTraceContext+    parentTs :: TraceState+    parentTs = traceState $ parentW3cTraceContext+    (parentTsHead, parentTsTail) =+      ( traceStateHead parentTs+      , traceStateTail parentTs+      )+  in+  W3CTraceContext+  { traceParent = TraceParent+    { version  = 0+    , traceId  = traceId $ parentTp+    , parentId = exitSpanSpanId+    , flags    = Flags+      { sampled = True+      }+    }+  , traceState = TraceState+    { traceStateHead      = Nothing+    , instanaKeyValuePair = Just InstanaKeyValuePair+      { instanaTraceId  = exitSpanTraceId+      , instanaParentId = exitSpanSpanId+      }+    , traceStateTail =+        case (parentTsHead, parentTsTail) of+          (Nothing, Nothing) ->+            Nothing+          _ ->+            Just $ T.intercalate "," $+              Maybe.catMaybes+               [ parentTsHead+               , parentTsTail+               ]+    }+  }+++-- |Creates a new W3C trace context value for an outgoing HTTP request when+-- tracing is suppressed.+inheritFromForSuppressed :: W3CTraceContext -> Id -> W3CTraceContext+inheritFromForSuppressed parentW3cTraceContext exitSpanSpanId =+  let+    parentTp = traceParent $ parentW3cTraceContext+    parentTs :: TraceState+    parentTs = traceState $ parentW3cTraceContext+    parentTsHead = traceStateHead parentTs+    parentTsTail = traceStateTail parentTs+  in+  W3CTraceContext+  { traceParent = TraceParent+    { version  = 0+    , traceId  = traceId $ parentTp+    , parentId = exitSpanSpanId+    , flags    = Flags+      { sampled = False+      }+    }+  , traceState = TraceState+    { traceStateHead      = parentTsHead+    , instanaKeyValuePair = Nothing+    , traceStateTail      = parentTsTail+    }+  }+++-- |Creates a new W3C trace context value for an outgoing HTTP request from the+-- given trace ID and span ID, without inheriting from an existing context.+exitSpanContextFromIds :: Id -> Id -> W3CTraceContext+exitSpanContextFromIds exitSpanTraceId exitSpanSpanId =+  W3CTraceContext+  { traceParent = TraceParent+    { version  = 0+    , traceId  = exitSpanTraceId+    , parentId = exitSpanSpanId+    , flags    = Flags+      { sampled = True+      }+    }+  , traceState = TraceState+    { traceStateHead      = Nothing+    , instanaKeyValuePair = Just InstanaKeyValuePair+      { instanaTraceId  = exitSpanTraceId+      , instanaParentId = exitSpanSpanId+      }+    , traceStateTail      = Nothing+    }+  }+++initBogusContextForSuppressedRequest :: IO W3CTraceContext+initBogusContextForSuppressedRequest = do+  bogusId <- Id.generate+  return $ createExitContextForSuppressed bogusId bogusId+++-- |When tracing is suppressed but no W3C trace context is incoming , we still+-- need to send down W3C trace context headers to signal sampled=false to+-- downstream services.+createExitContextForSuppressed :: Id -> Id -> W3CTraceContext+createExitContextForSuppressed bogusTraceId bogusParentId =+  W3CTraceContext+  { traceParent = TraceParent+    { version  = 0+    , traceId  = bogusTraceId+    , parentId = bogusParentId+    , flags    = Flags+      { sampled = False+      }+    }+  , traceState = TraceState+    { traceStateHead      = Nothing+    , instanaKeyValuePair = Nothing+    , traceStateTail      = Nothing+    }+  }+++-- |Serializes the given W3C trace context to a pair of HTTP headers.+toHeaders :: W3CTraceContext -> [HTTPTypes.Header]+toHeaders w3cTraceContext =+  let+    tp = traceParent w3cTraceContext+    traceparentHeader =+      Just+        ( TracingHeaders.traceparentHeaderName+        , encodeTraceParent tp+        )+    ts = traceState w3cTraceContext+    tracestateHeader =+      if isEmpty ts then+        Nothing+      else+        Just+          ( TracingHeaders.tracestateHeaderName+          , encodeTraceState ts+          )+  in+  Maybe.catMaybes [traceparentHeader, tracestateHeader]+++-- |Encodes the traceparent header value.+encodeTraceParent :: TraceParent -> BSC8.ByteString+encodeTraceParent tp =+  BSC8.concat+    [ BSC8.pack $ leftPad 2 $ show $ version tp+    , "-"+    , BSC8.pack $ leftPadAndLimit 32 $ Id.toStringUnshortened $ traceId tp+    , "-"+    , BSC8.pack $ leftPadAndLimit 16 $ Id.toString $ parentId tp+    , "-"+    , encodeFlags $ flags tp+    ]+++-- |Encodes the traceparent flag field.+encodeFlags :: Flags -> BSC8.ByteString+encodeFlags fl =+  if sampled fl then "01"+  else "00"+++-- |Encodes the tracestate header value.+encodeTraceState :: TraceState -> BSC8.ByteString+encodeTraceState ts =+  BSC8.intercalate "," $+    Maybe.catMaybes $+      -- We only encode for outgoing headers and for those we always move the+      -- Instana key value pair to the front in compliance with the W3C+      -- trace context specification+      ([ encodeInstanaKeyValuePair ts+       , (BSC8.pack . T.unpack) <$> traceStateHead ts+       , (BSC8.pack . T.unpack) <$> traceStateTail ts+      ])+++-- |Encodes the Instana key-value pair for the tracestate header value.+encodeInstanaKeyValuePair :: TraceState -> Maybe BSC8.ByteString+encodeInstanaKeyValuePair ts =+  let+    inKvPair = instanaKeyValuePair ts+    inTId = instanaTraceId <$> inKvPair+    inPId = instanaParentId <$> inKvPair+  in+  case (inTId, inPId) of+    (Just t, Just p) ->+      Just $+        BSC8.concat+          [ "in="+          , BSC8.pack $ leftPad 16 $ Id.toString t+          , ";"+          , BSC8.pack $ leftPad 16 $ Id.toString p+          ]++    _ ->+      Nothing+

@@ -22,6 +22,7 @@ import           GHC.Generics  import           Instana.SDK.Internal.Id (Id)+import qualified Instana.SDK.Internal.Id as Id   -- |Direction of the call.@@ -99,6 +100,8 @@   , serviceName     :: Maybe Text   , correlationType :: Maybe Text   , correlationId   :: Maybe Text+  , tpFlag          :: Maybe Bool+  , instanaAncestor :: Maybe (String, String)   , synthetic       :: Maybe Bool   , spanData        :: Value   } deriving (Eq, Generic, Show)@@ -118,10 +121,25 @@   toJSON :: WireSpan -> Value   toJSON wireSpan =     let+      tId = traceId span_+      longTraceId =+        case kind span_ of+          Entry -> Id.longTraceId tId+          _     -> Nothing       span_ = queuedSpan wireSpan       pid_ = pid wireSpan       agentUuid_ = agentUuid wireSpan       serviceNameConfig_ = serviceNameConfig wireSpan+      ia =+        case instanaAncestor span_ of+          Just (iaTId, iaPId) ->+            Just $ Aeson.object+              [ "t" .= iaTId+              , "p" .= iaPId+              ]+          Nothing ->+            Nothing+       spanData_ =         case (serviceName span_ <|> serviceNameConfig_) of           Just service ->@@ -132,7 +150,7 @@             spanData span_     in     Aeson.object-      [ "t"     .= traceId span_+      [ "t"     .= tId       , "s"     .= spanId span_       , "p"     .= parentId span_       , "n"     .= spanName span_@@ -143,6 +161,9 @@       , "crtp"  .= correlationType span_       , "crid"  .= correlationId span_       , "sy"    .= synthetic span_+      , "lt"    .= longTraceId+      , "tp"    .= tpFlag span_+      , "ia"    .= ia       , "data"  .= spanData_       , "f"     .= From pid_ agentUuid_       ]

@@ -38,12 +38,15 @@                                                                    ConnectionState (..),                                                                    InternalContext) import qualified Instana.SDK.Internal.Context                     as InternalContext+import qualified Instana.SDK.Internal.Id                          as Id import           Instana.SDK.Internal.Logging                     (instanaLogger) import qualified Instana.SDK.Internal.Metrics.Collector           as MetricsCollector import qualified Instana.SDK.Internal.Metrics.Compression         as MetricsCompression import qualified Instana.SDK.Internal.Metrics.Deltas              as Deltas import qualified Instana.SDK.Internal.Metrics.Sample              as Sample import qualified Instana.SDK.Internal.URL                         as URL+import           Instana.SDK.Internal.W3CTraceContext             (InstanaKeyValuePair (..))+import qualified Instana.SDK.Internal.W3CTraceContext             as W3CTraceContext import           Instana.SDK.Internal.WireSpan                    (QueuedSpan (QueuedSpan),                                                                    SpanKind (Entry, Exit),                                                                    WireSpan (WireSpan))@@ -125,6 +128,21 @@   now <- round . (* 1000) <$> getPOSIXTime   let     timestamp = EntrySpan.timestamp entrySpan+    instanaAncestor =+      case ( EntrySpan.tpFlag entrySpan+           , W3CTraceContext.instanaKeyValuePair =<<+             W3CTraceContext.traceState <$>+             EntrySpan.w3cTraceContext entrySpan+           ) of+        ( True+          , Just (InstanaKeyValuePair { instanaTraceId, instanaParentId })) ->+          Just ( Id.longOrShortTraceId instanaTraceId+               , Id.toString instanaParentId+               )++        _ ->+          Nothing+   queueSpan     context     QueuedSpan@@ -139,6 +157,9 @@       , WireSpan.serviceName     = EntrySpan.serviceName entrySpan       , WireSpan.correlationType = EntrySpan.correlationType entrySpan       , WireSpan.correlationId   = EntrySpan.correlationId entrySpan+      , WireSpan.tpFlag          =+          if EntrySpan.tpFlag entrySpan then Just True else Nothing+      , WireSpan.instanaAncestor = instanaAncestor       , WireSpan.synthetic       =           if EntrySpan.synthetic entrySpan then Just True else Nothing       , WireSpan.spanData        = EntrySpan.spanData entrySpan@@ -164,6 +185,8 @@       , WireSpan.serviceName     = ExitSpan.serviceName exitSpan       , WireSpan.correlationType = Nothing       , WireSpan.correlationId   = Nothing+      , WireSpan.tpFlag          = Nothing+      , WireSpan.instanaAncestor = Nothing       , WireSpan.synthetic       = Nothing       , WireSpan.spanData        = ExitSpan.spanData exitSpan       }

@@ -59,63 +59,67 @@     ) where  -import           Control.Concurrent                  (ThreadId)-import qualified Control.Concurrent                  as Concurrent-import           Control.Concurrent.STM              (STM)-import qualified Control.Concurrent.STM              as STM-import           Control.Monad                       (join, when)-import           Control.Monad.IO.Class              (MonadIO, liftIO)-import           Data.Aeson                          (Value, (.=))-import qualified Data.Aeson                          as Aeson-import qualified Data.ByteString.Char8               as BSC8-import qualified Data.List                           as List-import qualified Data.Map.Strict                     as Map-import qualified Data.Maybe                          as Maybe-import qualified Data.Sequence                       as Seq-import           Data.Text                           (Text)-import qualified Data.Text                           as T-import           Data.Time.Clock.POSIX               (getPOSIXTime)-import qualified Network.HTTP.Client                 as HTTP-import qualified Network.HTTP.Types                  as HTTPTypes-import qualified Network.Socket                      as Socket-import qualified Network.Wai                         as Wai-import           System.Log.Logger                   (warningM)-import qualified System.Posix.Process                as Process+import           Control.Concurrent                   (ThreadId)+import qualified Control.Concurrent                   as Concurrent+import           Control.Concurrent.STM               (STM)+import qualified Control.Concurrent.STM               as STM+import           Control.Monad                        (join, when)+import           Control.Monad.IO.Class               (MonadIO, liftIO)+import           Data.Aeson                           (Value, (.=))+import qualified Data.Aeson                           as Aeson+import qualified Data.ByteString.Char8                as BSC8+import qualified Data.List                            as List+import qualified Data.Map.Strict                      as Map+import qualified Data.Maybe                           as Maybe+import qualified Data.Sequence                        as Seq+import           Data.Text                            (Text)+import qualified Data.Text                            as T+import           Data.Time.Clock.POSIX                (getPOSIXTime)+import qualified Network.HTTP.Client                  as HTTP+import qualified Network.HTTP.Types                   as HTTPTypes+import qualified Network.Socket                       as Socket+import qualified Network.Wai                          as Wai+import           System.Log.Logger                    (warningM)+import qualified System.Posix.Process                 as Process  import           Instana.SDK.Config-import           Instana.SDK.Internal.Command        (Command)-import qualified Instana.SDK.Internal.Command        as Command-import           Instana.SDK.Internal.Config         (FinalConfig)-import qualified Instana.SDK.Internal.Config         as InternalConfig-import           Instana.SDK.Internal.Context        (ConnectionState (..),-                                                      InternalContext (InternalContext))-import qualified Instana.SDK.Internal.Context        as InternalContext-import           Instana.SDK.Internal.Id             (Id)-import qualified Instana.SDK.Internal.Id             as Id-import           Instana.SDK.Internal.Logging        (instanaLogger)-import qualified Instana.SDK.Internal.Logging        as Logging-import qualified Instana.SDK.Internal.Metrics.Sample as Sample-import qualified Instana.SDK.Internal.Secrets        as Secrets-import qualified Instana.SDK.Internal.ServerTiming   as ServerTiming-import           Instana.SDK.Internal.SpanStack      (SpanStack)-import qualified Instana.SDK.Internal.SpanStack      as SpanStack-import           Instana.SDK.Internal.Util           ((|>))-import qualified Instana.SDK.Internal.Worker         as Worker-import           Instana.SDK.Span.EntrySpan          (EntrySpan (..))-import           Instana.SDK.Span.ExitSpan           (ExitSpan (ExitSpan))-import qualified Instana.SDK.Span.ExitSpan           as ExitSpan-import           Instana.SDK.Span.NonRootEntry       (NonRootEntry (NonRootEntry))-import qualified Instana.SDK.Span.NonRootEntry       as NonRootEntry-import           Instana.SDK.Span.RootEntry          (RootEntry (RootEntry))-import qualified Instana.SDK.Span.RootEntry          as RootEntry-import           Instana.SDK.Span.SimpleSpan         (SimpleSpan)-import qualified Instana.SDK.Span.SimpleSpan         as SimpleSpan-import           Instana.SDK.Span.Span               (Span (..), SpanKind (..))-import qualified Instana.SDK.Span.Span               as Span-import           Instana.SDK.Span.SpanType           (SpanType (RegisteredSpan))-import qualified Instana.SDK.Span.SpanType           as SpanType-import           Instana.SDK.TracingHeaders          (TracingHeaders (TracingHeaders))-import qualified Instana.SDK.TracingHeaders          as TracingHeaders+import           Instana.SDK.Internal.Command         (Command)+import qualified Instana.SDK.Internal.Command         as Command+import           Instana.SDK.Internal.Config          (FinalConfig)+import qualified Instana.SDK.Internal.Config          as InternalConfig+import           Instana.SDK.Internal.Context         (ConnectionState (..),+                                                       InternalContext (InternalContext))+import qualified Instana.SDK.Internal.Context         as InternalContext+import           Instana.SDK.Internal.Id              (Id)+import qualified Instana.SDK.Internal.Id              as Id+import           Instana.SDK.Internal.Logging         (instanaLogger)+import qualified Instana.SDK.Internal.Logging         as Logging+import qualified Instana.SDK.Internal.Metrics.Sample  as Sample+import qualified Instana.SDK.Internal.Secrets         as Secrets+import qualified Instana.SDK.Internal.ServerTiming    as ServerTiming+import           Instana.SDK.Internal.SpanStack       (SpanStack)+import qualified Instana.SDK.Internal.SpanStack       as SpanStack+import           Instana.SDK.Internal.Util            ((|>))+import           Instana.SDK.Internal.W3CTraceContext (W3CTraceContext)+import qualified Instana.SDK.Internal.W3CTraceContext as W3CTraceContext+import qualified Instana.SDK.Internal.Worker          as Worker+import           Instana.SDK.Span.EntrySpan           (EntrySpan (..))+import qualified Instana.SDK.Span.EntrySpan           as EntrySpan+import           Instana.SDK.Span.ExitSpan            (ExitSpan (ExitSpan))+import qualified Instana.SDK.Span.ExitSpan            as ExitSpan+import           Instana.SDK.Span.NonRootEntry        (NonRootEntry (NonRootEntry))+import qualified Instana.SDK.Span.NonRootEntry        as NonRootEntry+import           Instana.SDK.Span.RootEntry           (RootEntry (RootEntry))+import qualified Instana.SDK.Span.RootEntry           as RootEntry+import           Instana.SDK.Span.SimpleSpan          (SimpleSpan)+import qualified Instana.SDK.Span.SimpleSpan          as SimpleSpan+import           Instana.SDK.Span.Span                (Span (..), SpanKind (..))+import qualified Instana.SDK.Span.Span                as Span+import           Instana.SDK.Span.SpanType            (SpanType (RegisteredSpan))+import qualified Instana.SDK.Span.SpanType            as SpanType+import           Instana.SDK.TracingHeaders           (TracingHeaders,+                                                       readHttpTracingHeaders)+import qualified Instana.SDK.TracingHeaders           as TracingHeaders   {-| A container for all the things the Instana SDK needs to do its work.@@ -123,6 +127,10 @@ type InstanaContext = InternalContext  +httpServerSpan :: SpanType+httpServerSpan = RegisteredSpan SpanType.HaskellWaiServer++ {-| Initializes the Instana SDK and the connection to the Instana agent.  The configuration is read from the environment, falling back to default values.@@ -263,6 +271,24 @@   return result  +-- |Wraps an IO action in 'startEntry' and 'completeEntry'. This internal method+-- accepts Id values instead of String values for trace ID/parent ID, to allow+-- span.lt to be transported alongside the shortened trace ID.+withEntry' ::+  MonadIO m =>+  InstanaContext+  -> Id+  -> Id+  -> SpanType+  -> m a+  -> m a+withEntry' context traceId parentId spanType io = do+  startEntry' context traceId parentId spanType+  result <- io+  completeEntry context+  return result++ -- |A convenience function that examines the given incoming HTTP request for -- Instana tracing headers -- (https://docs.instana.io/core_concepts/tracing/#http-tracing-headers)@@ -308,117 +334,78 @@   -> Wai.Request   -> m a   -> m a-withHttpEntry_ context request io = do-  let-    spanType = (RegisteredSpan SpanType.HaskellWaiServer)-    tracingHeaders = readHttpTracingHeaders request-    traceId = TracingHeaders.traceId tracingHeaders-    spanId = TracingHeaders.spanId tracingHeaders-    synthetic = TracingHeaders.synthetic tracingHeaders-    level = TracingHeaders.level tracingHeaders-    (traceId', spanId') =-      case TracingHeaders.correlationId tracingHeaders of-        Nothing ->-          (traceId, spanId)-        Just _ ->-          (Nothing, Nothing)--  case level of-    TracingHeaders.Trace -> do-      let-        io' = addDataFromRequest context request synthetic io-      case (traceId', spanId') of-        (Just t, Just s) ->-          withEntry context t s spanType io'-        _                -> do-          withRootEntry context spanType $-            addCorrelationTypeAndIdToSpan context tracingHeaders io'--    TracingHeaders.Suppress -> do-      liftIO $ pushSpan-        context-        (\stack ->-          case stack of-            Nothing ->-              -- We did not initialise the span stack for this thread, do it-              -- now.-              SpanStack.suppress-            Just spanStack ->-              SpanStack.pushSuppress spanStack-        )-      io----- |Takes an IO action and appends another side effecto to it that will add HTTP--- data from the given request to the current span.-addDataFromRequest ::-  MonadIO m =>-  InstanaContext ->-  Wai.Request ->-  Bool ->-  m a ->-  m a-addDataFromRequest context request synthetic originalIO =-  originalIO >>= addHttpDataInIO context request synthetic+withHttpEntry_ context request io =+  commonHttpHandling+    context+    request+    HttpTracingHandlers+      { continueFromInstanaHeaders = withHttpEntryContinueFromInstanaHeaders+      , continueFromTraceParent = withHttpEntryContinueFromTraceParent+      , continueFromTraceStateInstanaKeyValuePair =+          withHttpEntryContinueFromTraceStateInstanaKeyValuePair+      , createRoot = withHttpEntryRoot+      }+    io  -addHttpDataInIO ::-  MonadIO m =>-  InstanaContext ->-  Wai.Request ->-  Bool ->-  a ->-  m a-addHttpDataInIO context request synthetic ioResult = do-  addHttpData context request synthetic-  return ioResult+-- |A variant of 'withHttpEntry' that continues a trace from Instana headers+-- (X-INSTANA-T, X-INSTANA-S and X-INSTANA-L).+withHttpEntryContinueFromInstanaHeaders ::+  MonadIO m+  => InstanaContext+  -> String+  -> String+  -> m a+  -> m a+withHttpEntryContinueFromInstanaHeaders context t s io =+  withEntry context t s httpServerSpan io  -addHttpData :: MonadIO m => InstanaContext -> Wai.Request -> Bool -> m ()-addHttpData context request synthetic = do+-- |A variant of 'withHttpEntry' that continues a trace from the W3C trace+-- context headers traceparent.+withHttpEntryContinueFromTraceParent ::+  MonadIO m+  => InstanaContext+  -> W3CTraceContext+  -> m a+  -> m a+withHttpEntryContinueFromTraceParent context w3cTraceContext io =   let-    host :: String-    host =-      Wai.requestHeaderHost request-      |> fmap BSC8.unpack-      |> Maybe.fromMaybe ""-  addRegisteredData+    traceParent = W3CTraceContext.traceParent w3cTraceContext+  in+  withEntry'     context-    (Aeson.object [ "http" .=-      Aeson.object-        [ "method" .= Wai.requestMethod request |> BSC8.unpack-        , "url"    .= Wai.rawPathInfo request |> BSC8.unpack-        , "host"   .= host-        , "params" .= (processQueryString $ Wai.rawQueryString request)-        ]-      ]-    )-  setSynthetic context synthetic+    (W3CTraceContext.traceId traceParent)+    (W3CTraceContext.parentId traceParent)+    httpServerSpan+    (setSpanTpFlag context >> io)  -addCorrelationTypeAndIdToSpan ::-  MonadIO m =>-  InstanaContext+-- |A variant of 'withHttpEntry' that continues a trace from the Instana+-- key-value pair from the tracestate header.+withHttpEntryContinueFromTraceStateInstanaKeyValuePair ::+  MonadIO m+  => InstanaContext+  -> Id+  -> Id+  -> m a+  -> m a+withHttpEntryContinueFromTraceStateInstanaKeyValuePair context t s io =+  withEntry' context t s httpServerSpan io+++-- |A variant of 'withHttpEntry' that does not continue a trace but starts a+-- new trace.+withHttpEntryRoot ::+  MonadIO m+  => InstanaContext   -> TracingHeaders   -> m a   -> m a-addCorrelationTypeAndIdToSpan context tracingHeaders ioResult = do-  let-    correlationType = TracingHeaders.correlationType tracingHeaders-    correlationId = TracingHeaders.correlationId tracingHeaders-  case (correlationType, correlationId) of-    (Nothing, Nothing) ->-      ioResult-    (Just crtp, Nothing) -> do-      setCorrelationType context (T.pack crtp)-      ioResult-    (Nothing, Just crid) -> do-      setCorrelationId context (T.pack crid)-      ioResult-    (Just crtp, Just crid) -> do-      setCorrelationType context (T.pack crtp)-      setCorrelationId context (T.pack crid)-      ioResult+withHttpEntryRoot context tracingHeaders io =+  withRootEntry context httpServerSpan $+    addCorrelationTypeAndIdToSpan context tracingHeaders+    >> io   -- |Wraps an IO action in 'startExit' and 'completeExit'.@@ -475,6 +462,7 @@             , RootEntry.correlationType = Nothing             , RootEntry.correlationId   = Nothing             , RootEntry.spanData        = SpanType.initialData EntryKind spanType+            , RootEntry.w3cTraceContext = Nothing             }     pushSpan       context@@ -499,6 +487,24 @@   -> SpanType   -> m () startEntry context traceId parentId spanType = do+  let+    tId = Id.fromString traceId+    pId = Id.fromString parentId+  startEntry' context tId pId spanType+++-- |Creates a preliminary/incomplete entry span, which should later be completed+-- by calling 'completeEntry'. This internal method accepts Id values instead of+-- String values for trace ID/parent ID, to allow span.lt to be transported+-- alongside the shortened trace ID.+startEntry' ::+  MonadIO m =>+  InstanaContext+  -> Id+  -> Id+  -> SpanType+  -> m ()+startEntry' context traceId parentId spanType = do   liftIO $ do     timestamp <- round . (* 1000) <$> getPOSIXTime     spanId <- Id.generate@@ -506,22 +512,25 @@       newSpan =         NonRootEntrySpan $           NonRootEntry-            { NonRootEntry.traceId     = Id.fromString traceId-            , NonRootEntry.spanId      = spanId-            , NonRootEntry.parentId    = Id.fromString parentId-            , NonRootEntry.spanName    = SpanType.spanName spanType-            , NonRootEntry.timestamp   = timestamp-            , NonRootEntry.errorCount  = 0-            , NonRootEntry.serviceName = Nothing-            , NonRootEntry.synthetic   = False-            , NonRootEntry.spanData    = SpanType.initialData EntryKind spanType+            { NonRootEntry.traceId         = traceId+            , NonRootEntry.spanId          = spanId+            , NonRootEntry.parentId        = parentId+            , NonRootEntry.spanName        = SpanType.spanName spanType+            , NonRootEntry.timestamp       = timestamp+            , NonRootEntry.errorCount      = 0+            , NonRootEntry.serviceName     = Nothing+            , NonRootEntry.synthetic       = False+            , NonRootEntry.spanData        = SpanType.initialData EntryKind spanType+            , NonRootEntry.w3cTraceContext = Nothing+            , NonRootEntry.tpFlag          = False             }     pushSpan       context       (\stack ->         case stack of           Nothing ->-            -- We did not initialise the span stack for this thread, do it now.+            -- We did not initialise the span stack for this thread yet, do+            -- it now.             SpanStack.entry newSpan           Just spanStack ->             spanStack@@ -540,14 +549,134 @@   -> Wai.Request   -> m () startHttpEntry context request = do+  commonHttpHandling+    context+    request+    HttpTracingHandlers+      { continueFromInstanaHeaders = startHttpEntryContinueFromInstanaHeaders+      , continueFromTraceParent = startHttpEntryContinueFromTraceParent+      , continueFromTraceStateInstanaKeyValuePair =+          startHttpEntryContinueFromTraceStateInstanaKeyValuePair+      , createRoot = startHttpEntryRoot+      }+    (return ())+++-- |A variant of 'startHttpEntry' that continues a trace from Instana headers+-- (X-INSTANA-T, X-INSTANA-S and X-INSTANA-L).+startHttpEntryContinueFromInstanaHeaders ::+  MonadIO m+  => InstanaContext+  -> String+  -> String+  -> m a+  -> m a+startHttpEntryContinueFromInstanaHeaders context t s io = do+  startEntry context t s httpServerSpan+  io+++-- |A variant of 'startHttpEntry' that continues a trace from the W3C trace+-- context headers traceparent.+startHttpEntryContinueFromTraceParent ::+  MonadIO m+  => InstanaContext+  -> W3CTraceContext+  -> m a+  -> m a+startHttpEntryContinueFromTraceParent context w3cTraceContext io = do   let-    spanType = (RegisteredSpan SpanType.HaskellWaiServer)+    traceParent = W3CTraceContext.traceParent w3cTraceContext+  startEntry'+    context+    (W3CTraceContext.traceId traceParent)+    (W3CTraceContext.parentId traceParent)+    httpServerSpan+  (setSpanTpFlag context >> io)+++-- |A variant of 'startHttpEntry' that continues a trace from the Instana+-- key-value pair from the tracestate header.+startHttpEntryContinueFromTraceStateInstanaKeyValuePair ::+  MonadIO m+  => InstanaContext+  -> Id+  -> Id+  -> m a+  -> m a+startHttpEntryContinueFromTraceStateInstanaKeyValuePair+    context+    t+    s+    io = do+  startEntry'+    context+    t+    s+    httpServerSpan+  io+++-- |A variant of 'startHttpEntry' that does not continue a trace but starts a+-- new trace.+startHttpEntryRoot ::+  MonadIO m+  => InstanaContext+  -> TracingHeaders+  -> m a+  -> m a+startHttpEntryRoot context tracingHeaders io = do+  startRootEntry context httpServerSpan+  addCorrelationTypeAndIdToSpan context tracingHeaders+  io+++-- |A set of handlers to continue a trace from incoming headers or create a+-- new trace, which can be either used from withHttpEntry or startHttpEntry.+data HttpTracingHandlers m a = HttpTracingHandlers+  { continueFromInstanaHeaders ::+      InstanaContext+      -> String+      -> String+      -> m a+      -> m a+  , continueFromTraceParent ::+      InstanaContext+      -> W3CTraceContext+      -> m a+      -> m a+  , continueFromTraceStateInstanaKeyValuePair ::+      InstanaContext+      -> Id+      -> Id+      -> m a+      -> m a+  , createRoot ::+      InstanaContext+      -> TracingHeaders+      -> m a+      -> m a+  }+++-- |Bundles common handling for startHttpEntry and withHttpEntry.+commonHttpHandling ::+  MonadIO m =>+  InstanaContext+  -> Wai.Request+  -> HttpTracingHandlers m a+  -> m a+  -> m a+commonHttpHandling context request httpTracingHandlers io = do+  let     tracingHeaders = readHttpTracingHeaders request     traceId = TracingHeaders.traceId tracingHeaders     spanId = TracingHeaders.spanId tracingHeaders-    synthetic = TracingHeaders.synthetic tracingHeaders     level = TracingHeaders.level tracingHeaders-    -- ignore incoming X-INSTANA-T/-S if eum correlation data is present+    traceparent = TracingHeaders.traceparent tracingHeaders+    tracestate = TracingHeaders.tracestate tracingHeaders++    -- discard incoming X-INSTANA-T/-S if eum correlation data is present     (traceId', spanId') =       case TracingHeaders.correlationId tracingHeaders of         Nothing ->@@ -555,30 +684,191 @@         Just _ ->           (Nothing, Nothing) +    w3cTraceContext =+      case traceparent of+        Just tp ->+          W3CTraceContext.decode tp tracestate+        Nothing ->+          Nothing+   case level of+     TracingHeaders.Trace ->-      case (traceId', spanId') of-        (Just t, Just s) -> do-          startEntry context t s spanType-          addHttpData context request synthetic-        _                -> do-          startRootEntry context spanType-          addHttpData context request synthetic-          addCorrelationTypeAndIdToSpan context tracingHeaders $ return ()+      executeTracedHttpRequest+        context+        request+        httpTracingHandlers+        tracingHeaders+        w3cTraceContext+        traceId'+        spanId'+        io -    TracingHeaders.Suppress -> do-      liftIO $ pushSpan+    TracingHeaders.Suppress ->+      executeSuppressedHttpRequest context w3cTraceContext io+++-- |Evaluates the incoming headers (Instana headers and W3C trace context) and+-- decides from which set of headers to continue the trace (or to start a new+-- trace).+executeTracedHttpRequest ::+  MonadIO m =>+  InstanaContext+  -> Wai.Request+  -> HttpTracingHandlers m a+  -> TracingHeaders+  -> Maybe W3CTraceContext+  -> Maybe String+  -> Maybe String+  -> m a+  -> m a+executeTracedHttpRequest+    context+    request+    httpTracingHandlers+    tracingHeaders+    w3cTraceContext+    traceId+    spanId+    io = do+  let+    synthetic = TracingHeaders.synthetic tracingHeaders++    io' =+      (setW3cTraceContext context w3cTraceContext)+      >> io+      >>= (\ioResult -> do+        addHttpData context request synthetic+        return ioResult+      )++    w3cTsInKvPair =+      join $+        W3CTraceContext.instanaKeyValuePair <$>+          W3CTraceContext.traceState <$> w3cTraceContext+    tIdFromW3cInKvPair = W3CTraceContext.instanaTraceId <$> w3cTsInKvPair+    pIdFromW3cInKvPair = W3CTraceContext.instanaParentId <$> w3cTsInKvPair++    w3cTraceCorrelationDisabled =+      InternalConfig.disableW3cTraceCorrelation . InternalContext.config $         context-        (\stack ->-          case stack of-            Nothing ->-              -- We did not initialise the span stack for this thread, do it now.-              SpanStack.suppress-            Just spanStack ->-              SpanStack.pushSuppress spanStack-        ) +  case ( traceId+       , spanId+       , w3cTraceContext+       , w3cTraceCorrelationDisabled+       , tIdFromW3cInKvPair+       , pIdFromW3cInKvPair+       ) of +    (Just t, Just s, _, _, _, _) ->+      (continueFromInstanaHeaders httpTracingHandlers)+        context+        t+        s+        io'++    (_, _, Just w3cCtx, False, _, _) ->+      (continueFromTraceParent httpTracingHandlers)+        context+        w3cCtx+        io'++    (_, _, _, True, Just t, Just s) ->+      (continueFromTraceStateInstanaKeyValuePair httpTracingHandlers)+        context+        t+        s+        io'++    _                ->+      (createRoot httpTracingHandlers)+        context+        tracingHeaders+        io'+++-- |Handles an incoming HTTP request when tracing is suppressed.+executeSuppressedHttpRequest ::+  MonadIO m =>+  InstanaContext+  -> Maybe W3CTraceContext+  -> m a+  -> m a+executeSuppressedHttpRequest context maybeW3cTraceContext io = do+  liftIO $ do+    w3cTraceContext <-+      case maybeW3cTraceContext of+        Just w3cCtx ->+          return w3cCtx+        Nothing -> do+          W3CTraceContext.initBogusContextForSuppressedRequest+    pushSpan+      context+      (\stack ->+        case stack of+          Nothing ->+            -- We did not initialise the span stack for this thread, do it+            -- now.+            SpanStack.suppress w3cTraceContext+          Just spanStack ->+            SpanStack.pushSuppress w3cTraceContext spanStack+      )+  io+++addHttpData ::+  MonadIO m =>+  InstanaContext ->+  Wai.Request ->+  Bool ->+  m ()+addHttpData context request synthetic = do+  let+    host :: String+    host =+      Wai.requestHeaderHost request+      |> fmap BSC8.unpack+      |> Maybe.fromMaybe ""+  addRegisteredData+    context+    (Aeson.object [ "http" .=+      Aeson.object+        [ "method" .= Wai.requestMethod request |> BSC8.unpack+        , "url"    .= Wai.rawPathInfo request |> BSC8.unpack+        , "host"   .= host+        , "params" .= (processQueryString $ Wai.rawQueryString request)+        ]+      ]+    )+  setSynthetic context synthetic+++-- |Adds website correlation annotations to the HTTP entry span.+addCorrelationTypeAndIdToSpan ::+  MonadIO m =>+  InstanaContext+  -> TracingHeaders+  -> m ()+addCorrelationTypeAndIdToSpan context tracingHeaders = do+  let+    correlationType = TracingHeaders.correlationType tracingHeaders+    correlationId = TracingHeaders.correlationId tracingHeaders+  case (correlationType, correlationId) of+    (Nothing, Nothing) ->+      return ()+    (Just crtp, Nothing) -> do+      setCorrelationType context (T.pack crtp)+      return ()+    (Nothing, Just crid) -> do+      setCorrelationId context (T.pack crid)+      return ()+    (Just crtp, Just crid) -> do+      setCorrelationType context (T.pack crtp)+      setCorrelationId context (T.pack crid)+      return ()++ -- |Processes the response of an HTTP entry. This function needs be called while -- the HTTP entry span is still active. It can be used inside a 'withHttpEntry_' -- block or between 'startHttpEntry' and 'completeEntry'.@@ -596,9 +886,9 @@ -- both of these things automatically. -- -- Clients should make sure to call this in the context provided above, that is,--- within 'withHttpEntry_' or between 'startHttpEntry' and 'completeHttpEntry'--- but outside of blocks that create an exit span, that is, outside of--- 'withExit', 'withHttpExit' and not between 'startExit' and 'completeExit'.+-- within 'withHttpEntry_' or between 'startHttpEntry' and 'completeEntry' but+-- outside of blocks that create an exit span, that is, outside of 'withExit',+-- 'withHttpExit' and not between 'startExit' and 'completeExit'. postProcessHttpResponse ::   MonadIO m =>   InstanaContext@@ -683,13 +973,15 @@   -> IO Wai.Response addWebsiteMonitoringBackEndCorrelationUnlifted context response = do   traceIdMaybe <- currentTraceIdInternal context-  case traceIdMaybe of-    Nothing -> return response-    Just traceId  ->+  suppressed <- isSuppressed context+  case (traceIdMaybe, suppressed) of+    (Just traceId, False) ->       return $         Wai.mapResponseHeaders         (ServerTiming.addTraceIdToServerTiming traceId)         response+    _ ->+      return response   -- |Creates a preliminary/incomplete exit span, which should later be completed@@ -711,15 +1003,30 @@           spanId <- Id.generate           timestamp <- round . (* 1000) <$> getPOSIXTime           let+            parentW3cTraceContext = EntrySpan.w3cTraceContext parent+            w3cTraceContext =+              case parentW3cTraceContext of+                Just w3cCtx ->+                  W3CTraceContext.inheritFrom+                    w3cCtx+                    (EntrySpan.traceId parent)+                    spanId+                Nothing ->+                  W3CTraceContext.exitSpanContextFromIds+                    (EntrySpan.traceId parent)+                    spanId             newSpan =               ExitSpan-                { ExitSpan.parentSpan  = parent-                , ExitSpan.spanId      = spanId-                , ExitSpan.spanName    = SpanType.spanName spanType-                , ExitSpan.timestamp   = timestamp-                , ExitSpan.errorCount  = 0-                , ExitSpan.serviceName = Nothing-                , ExitSpan.spanData    = SpanType.initialData ExitKind spanType+                { ExitSpan.parentSpan      = parent+                , ExitSpan.spanId          = spanId+                , ExitSpan.spanName        = SpanType.spanName spanType+                , ExitSpan.timestamp       = timestamp+                , ExitSpan.errorCount      = 0+                , ExitSpan.serviceName     = Nothing+                , ExitSpan.spanData        = SpanType.initialData+                                               ExitKind+                                               spanType+                , ExitSpan.w3cTraceContext = w3cTraceContext                 }           pushSpan             context@@ -918,6 +1225,31 @@     (\span_ -> Span.setCorrelationId correlationId_ span_)  +-- |Attaches a W3C trace context to the currently active span.+setW3cTraceContext ::+  MonadIO m =>+  InstanaContext ->+  Maybe W3CTraceContext ->+  m ()+setW3cTraceContext context w3cTraceContext =+  liftIO $ do+    case w3cTraceContext of+      Just w3cCtx ->+        modifyCurrentSpan context+          (\span_ -> Span.setW3cTraceContext w3cCtx span_)+      Nothing ->+        return ()+++-- |Sets the tp flag on the current span to mark it as a span that has+-- inherited the trace ID/parent ID from W3C trace context instead of Instana+-- headers.+setSpanTpFlag :: MonadIO m => InstanaContext -> m ()+setSpanTpFlag context =+  liftIO $ modifyCurrentSpan context+    (\span_ -> Span.setTpFlag span_)++ -- |Set the synthetic flag. This should only be set on entry spans. It will be -- silently ignored for other types of spans. setSynthetic :: MonadIO m => InstanaContext -> Bool -> m ()@@ -1018,44 +1350,6 @@     (\span_ -> Span.addRegisteredData value span_)  --- |Reads the Instana tracing headers--- (https://docs.instana.io/core_concepts/tracing/#http-tracing-headers) from--- the given request.-readHttpTracingHeaders :: Wai.Request -> TracingHeaders-readHttpTracingHeaders request =-  let-    headers = Wai.requestHeaders request-    -- lookup is automatically case insensitive because-    -- HeaderName = CI ByteString (CI -> Case Insensitive String)-    traceId =-      headers-      |> List.lookup TracingHeaders.traceIdHeaderName-      |> (<$>) BSC8.unpack-    spanId =-      headers-      |> List.lookup TracingHeaders.spanIdHeaderName-      |> (<$>) BSC8.unpack-    xInstanaLValue =-      headers-      |> List.lookup TracingHeaders.levelHeaderName-      |> (<$>) BSC8.unpack-    (level, correlationType, correlationId) =-      TracingHeaders.parseXInstanaL xInstanaLValue-    synthetic =-      headers-      |> List.lookup TracingHeaders.syntheticHeaderName-      |> (<$>) BSC8.unpack-  in-  TracingHeaders-    { TracingHeaders.traceId = traceId-    , TracingHeaders.spanId = spanId-    , TracingHeaders.level = level-    , TracingHeaders.correlationType = correlationType-    , TracingHeaders.correlationId = correlationId-    , TracingHeaders.synthetic = synthetic == (Just "1")-    }-- -- |Adds the Instana tracing headers -- (https://docs.instana.io/core_concepts/tracing/#http-tracing-headers) -- from the currently active span to the given HTTP client request.@@ -1069,45 +1363,72 @@     suppressed <- isSuppressed context     traceId <- currentTraceIdInternal context     spanId <- currentSpanIdInternal context+    w3cTraceContext <- currentW3cTraceContext context     let       originalHeaders = HTTP.requestHeaders request-      updatedRequest =-        case (traceId, spanId, suppressed) of-          (_, _, True) ->-            request {-              HTTP.requestHeaders =-                ((TracingHeaders.levelHeaderName, "0") : originalHeaders)-            }-          (Just tId, Just sId, False) ->-            request {-              HTTP.requestHeaders =-                (originalHeaders ++-                  [ (TracingHeaders.traceIdHeaderName, Id.toByteString tId)-                  , (TracingHeaders.spanIdHeaderName, Id.toByteString sId)-                  ]-                )-            }-          (Just tId, Nothing, False) ->-            request {-              HTTP.requestHeaders =-                (originalHeaders ++-                  [ (TracingHeaders.traceIdHeaderName, Id.toByteString tId)-                  ]-                )-            }-          (Nothing, Just sId, False) ->-            request {-              HTTP.requestHeaders =-                (originalHeaders ++-                  [ (TracingHeaders.spanIdHeaderName, Id.toByteString sId)-                  ]-                )-            }-          _ ->-            request-    return updatedRequest+    case (traceId, spanId, suppressed) of+      (_, _, True) -> do+          suppressedW3cTraceContext <-+            case w3cTraceContext of+              Just w3cCtx -> do+                bogusParentId <- Id.generate+                return $+                  W3CTraceContext.inheritFromForSuppressed+                    w3cCtx+                    bogusParentId+              Nothing -> do+                bogusTraceIdFromStack <- currentTraceIdInternal context+                bogusTraceId <-+                  case bogusTraceIdFromStack of+                    Just tId -> return tId+                    Nothing  -> Id.generate+                bogusParentId <- Id.generate+                return $ W3CTraceContext.createExitContextForSuppressed bogusTraceId bogusParentId+          return $ request {+            HTTP.requestHeaders =+              ((TracingHeaders.levelHeaderName, "0") : originalHeaders)+              ++ (w3cTraceContextToHeaders $ Just suppressedW3cTraceContext)+          } +      (Just tId, Just sId, False) ->+        return $ request {+          HTTP.requestHeaders =+            (originalHeaders +++              [ (TracingHeaders.traceIdHeaderName, Id.toByteString tId)+              , (TracingHeaders.spanIdHeaderName, Id.toByteString sId)+              ]+              ++ w3cTraceContextToHeaders w3cTraceContext+            )+        }+      (Just tId, Nothing, False) ->+        return $ request {+          HTTP.requestHeaders =+            (originalHeaders +++              [ (TracingHeaders.traceIdHeaderName, Id.toByteString tId)+              ]+              ++ w3cTraceContextToHeaders w3cTraceContext+            )+        }+      (Nothing, Just sId, False) ->+        return $ request {+          HTTP.requestHeaders =+            (originalHeaders +++              [ (TracingHeaders.spanIdHeaderName, Id.toByteString sId)+              ]+              ++ w3cTraceContextToHeaders w3cTraceContext+            )+        }+      _ ->+        return request ++w3cTraceContextToHeaders :: Maybe W3CTraceContext -> [HTTPTypes.Header]+w3cTraceContextToHeaders w3cTraceContext =+  case w3cTraceContext of+    Just w3cCtx -> W3CTraceContext.toHeaders w3cCtx+    Nothing     -> []++ -- |Sends a command to the worker thread. enqueueCommand :: InstanaContext -> Command -> IO () enqueueCommand context command = do@@ -1241,6 +1562,15 @@ isSuppressed context = do   suppressedMaybe <- readFromSpanStack context SpanStack.isSuppressed   return $ Maybe.fromMaybe False suppressedMaybe+++-- |Retrieves the W3C trace context attached to currently active span in the+-- current thread.+currentW3cTraceContext :: InstanaContext -> IO (Maybe W3CTraceContext)+currentW3cTraceContext context = do+  w3cTraceContextMaybe <-+    readFromSpanStack context SpanStack.readW3cTraceContext+  return $ join w3cTraceContextMaybe   -- |Reads a value from the currently active span stack.

@@ -16,24 +16,29 @@   , setCorrelationType   , setServiceName   , setSynthetic+  , setTpFlag+  , setW3cTraceContext   , spanData   , spanId   , spanName   , synthetic+  , tpFlag   , timestamp   , traceId+  , w3cTraceContext   ) where  -import           Data.Aeson                    (Value)-import           Data.Text                     (Text)+import           Data.Aeson                           (Value)+import           Data.Text                            (Text) import           GHC.Generics -import           Instana.SDK.Internal.Id       (Id)-import           Instana.SDK.Span.NonRootEntry (NonRootEntry)-import qualified Instana.SDK.Span.NonRootEntry as NonRootEntry-import           Instana.SDK.Span.RootEntry    (RootEntry)-import qualified Instana.SDK.Span.RootEntry    as RootEntry+import           Instana.SDK.Internal.Id              (Id)+import           Instana.SDK.Internal.W3CTraceContext (W3CTraceContext)+import           Instana.SDK.Span.NonRootEntry        (NonRootEntry)+import qualified Instana.SDK.Span.NonRootEntry        as NonRootEntry+import           Instana.SDK.Span.RootEntry           (RootEntry)+import qualified Instana.SDK.Span.RootEntry           as RootEntry   -- |An entry span.@@ -163,6 +168,49 @@   case entrySpan of     RootEntrySpan entry    -> RootEntry.synthetic entry     NonRootEntrySpan entry -> NonRootEntry.synthetic entry+++-- |The W3C Trace Context. An entry span only has an associated W3C trace+-- context, if W3C trace context headers have been received. In contrast,+-- exit spans always have an associated W3C trace context.+w3cTraceContext :: EntrySpan -> Maybe W3CTraceContext+w3cTraceContext entrySpan =+  case entrySpan of+    RootEntrySpan entry    -> RootEntry.w3cTraceContext entry+    NonRootEntrySpan entry -> NonRootEntry.w3cTraceContext entry+++-- |Attaches a W3C trace context to the span.+setW3cTraceContext :: W3CTraceContext -> EntrySpan -> EntrySpan+setW3cTraceContext w3cTraceContext_ entrySpan =+   case entrySpan of+    RootEntrySpan entry ->+      RootEntrySpan $ RootEntry.setW3cTraceContext w3cTraceContext_ entry+    NonRootEntrySpan entry ->+      NonRootEntrySpan $ NonRootEntry.setW3cTraceContext w3cTraceContext_ entry+++-- |The span.tp flag. A span with span.tp = True has inherited the trace ID/+-- parent ID from W3C trace context instead of Instana headers. Only valid for+-- entry spans.+tpFlag :: EntrySpan -> Bool+tpFlag entrySpan =+  case entrySpan of+    RootEntrySpan _        -> False+    NonRootEntrySpan entry -> NonRootEntry.tpFlag entry+++-- |Set the span.tp flag. A span with span.tp = True has inherited the trace ID/+-- parent ID from W3C trace context instead of Instana headers. Only valid for+-- non-root entry spans, will be silently ignored for root entry spans and exit+-- spans.+setTpFlag :: EntrySpan -> EntrySpan+setTpFlag entrySpan =+  case entrySpan of+    RootEntrySpan _        ->+      entrySpan+    NonRootEntrySpan entry ->+      NonRootEntrySpan $ NonRootEntry.setTpFlag entry   -- |Set the synthetic flag. This should only be set on entry spans. It will be

@@ -10,17 +10,19 @@   , addData   , addToErrorCount   , setServiceName+  , setW3cTraceContext   ) where  -import           Data.Aeson                 (Value)-import qualified Data.Aeson.Extra.Merge     as AesonExtra-import           Data.Text                  (Text)+import           Data.Aeson                           (Value)+import qualified Data.Aeson.Extra.Merge               as AesonExtra+import           Data.Text                            (Text) import           GHC.Generics -import           Instana.SDK.Internal.Id    (Id)-import           Instana.SDK.Span.EntrySpan (EntrySpan)-import qualified Instana.SDK.Span.EntrySpan as EntrySpan+import           Instana.SDK.Internal.Id              (Id)+import           Instana.SDK.Internal.W3CTraceContext (W3CTraceContext)+import           Instana.SDK.Span.EntrySpan           (EntrySpan)+import qualified Instana.SDK.Span.EntrySpan           as EntrySpan   -- |An exit span.@@ -28,22 +30,26 @@   ExitSpan     {       -- |The parent span-      parentSpan  :: EntrySpan+      parentSpan      :: EntrySpan       -- |The span ID-    , spanId      :: Id+    , spanId          :: Id       -- |The span name/type, e.g. a short string like "haskell.wai.server",       -- "haskell.http.client". For SDK spans this is always "sdk", the actual       -- name is then in span.data.sdk.name.-    , spanName    :: Text+    , spanName        :: Text       -- |The time the span started-    , timestamp   :: Int+    , timestamp       :: Int       -- |An attribute for overriding the name of the service in Instana-    , serviceName :: Maybe Text+    , serviceName     :: Maybe Text       -- |The number of errors that occured during processing-    , errorCount  :: Int+    , errorCount      :: Int       -- |Additional data for the span. Must be provided as an       -- 'Data.Aeson.Value'.-    , spanData    :: Value+    , spanData        :: Value+      -- |The W3C Trace Context. An entry span only has an associated W3C trace+      -- context, if W3C trace context headers have been received. In contrast,+      -- spans always have an associated W3C trace context.+    , w3cTraceContext :: W3CTraceContext     } deriving (Eq, Generic, Show)  @@ -72,6 +78,12 @@ setServiceName :: Text -> ExitSpan -> ExitSpan setServiceName serviceName_ exitSpan =   exitSpan { serviceName = Just serviceName_ }+++-- |Attaches a W3C trace context to the span.+setW3cTraceContext :: W3CTraceContext -> ExitSpan -> ExitSpan+setW3cTraceContext w3cTraceContext_ exitSpan =+  exitSpan { w3cTraceContext = w3cTraceContext_ }   -- |Add a value to the span's data section.

@@ -9,15 +9,18 @@   , addToErrorCount   , setServiceName   , setSynthetic+  , setTpFlag+  , setW3cTraceContext   ) where  -import           Data.Aeson              (Value)-import qualified Data.Aeson.Extra.Merge  as AesonExtra-import           Data.Text               (Text)+import           Data.Aeson                           (Value)+import qualified Data.Aeson.Extra.Merge               as AesonExtra+import           Data.Text                            (Text) import           GHC.Generics -import           Instana.SDK.Internal.Id (Id)+import           Instana.SDK.Internal.Id              (Id)+import           Instana.SDK.Internal.W3CTraceContext (W3CTraceContext)   -- |An entry span that is not the root span of a trace.@@ -25,26 +28,32 @@   NonRootEntry     {       -- |The trace ID-      traceId     :: Id+      traceId         :: Id       -- |The span ID-    , spanId      :: Id+    , spanId          :: Id       -- |The ID of the parent span-    , parentId    :: Id+    , parentId        :: Id       -- |The span name/type, e.g. a short string like "haskell.wai.server",       -- "haskell.http.client". For SDK spans this is always "sdk", the actual       -- name is then in span.data.sdk.name.-    , spanName    :: Text+    , spanName        :: Text       -- |The time the span started-    , timestamp   :: Int+    , timestamp       :: Int       -- |The number of errors that occured during processing-    , errorCount  :: Int+    , errorCount      :: Int       -- |An attribute for overriding the name of the service in Instana-    , serviceName :: Maybe Text+    , serviceName     :: Maybe Text       -- |A flag indicating that this span represents a synthetic call-    , synthetic   :: Bool+    , synthetic       :: Bool       -- |Additional data for the span. Must be provided as an       -- 'Data.Aeson.Value'.-    , spanData    :: Value+    , spanData        :: Value+      -- |The W3C Trace Context. An entry span only has an associated W3C trace+      -- context, if W3C trace context headers have been received.+    , w3cTraceContext :: Maybe W3CTraceContext+      -- |The span.tp flag. A span with span.tp = True has inherited the+      -- trace ID/parent ID from W3C trace context instead of Instana headers.+    , tpFlag          :: Bool     } deriving (Eq, Generic, Show)  @@ -61,6 +70,19 @@ setServiceName :: Text -> NonRootEntry -> NonRootEntry setServiceName serviceName_ nonRootEntry =   nonRootEntry { serviceName = Just serviceName_ }+++-- |Attaches a W3C trace context to the span.+setW3cTraceContext :: W3CTraceContext -> NonRootEntry -> NonRootEntry+setW3cTraceContext w3cTraceContext_ nonRootEntry =+  nonRootEntry { w3cTraceContext = Just w3cTraceContext_ }+++-- |Set the span.tp flag. A span with span.tp = True has inherited the trace ID/+-- parent ID from W3C trace context instead of Instana headers.+setTpFlag :: NonRootEntry -> NonRootEntry+setTpFlag nonRootEntry =+  nonRootEntry { tpFlag = True }   -- |Set the synthetic flag.

@@ -13,15 +13,17 @@   , setCorrelationType   , setCorrelationId   , setSynthetic+  , setW3cTraceContext   ) where  -import           Data.Aeson              (Value)-import qualified Data.Aeson.Extra.Merge  as AesonExtra-import           Data.Text               (Text)+import           Data.Aeson                           (Value)+import qualified Data.Aeson.Extra.Merge               as AesonExtra+import           Data.Text                            (Text) import           GHC.Generics -import           Instana.SDK.Internal.Id (Id)+import           Instana.SDK.Internal.Id              (Id)+import           Instana.SDK.Internal.W3CTraceContext (W3CTraceContext)   -- |An entry span that is the root span of a trace.@@ -49,6 +51,10 @@       -- |Additional data for the span. Must be provided as an       -- 'Data.Aeson.Value'.     , spanData        :: Value+      -- |The W3C Trace Context. An entry span only has an associated W3C trace+      -- context, if W3C trace context headers have been received.+    , w3cTraceContext :: Maybe W3CTraceContext+     } deriving (Eq, Generic, Show)  @@ -75,6 +81,12 @@ setServiceName :: Text -> RootEntry -> RootEntry setServiceName serviceName_ rootEntry =   rootEntry { serviceName = Just serviceName_ }+++-- |Attaches a W3C trace context to the span.+setW3cTraceContext :: W3CTraceContext -> RootEntry -> RootEntry+setW3cTraceContext w3cTraceContext_ rootEntry =+  rootEntry { w3cTraceContext = Just w3cTraceContext_ }   -- |Set the synthetic flag.

@@ -21,27 +21,32 @@   , setCorrelationType   , setServiceName   , setSynthetic+  , setW3cTraceContext   , spanData+  , setTpFlag   , spanId   , spanKind   , spanName   , synthetic   , timestamp+  , tpFlag   , traceId+  , w3cTraceContext   ) where  -import           Data.Aeson                 (Value, (.=))-import qualified Data.Aeson                 as Aeson-import qualified Data.List                  as List-import           Data.Text                  as T+import           Data.Aeson                           (Value, (.=))+import qualified Data.Aeson                           as Aeson+import qualified Data.List                            as List+import           Data.Text                            as T import           GHC.Generics -import           Instana.SDK.Internal.Id    (Id)-import           Instana.SDK.Span.EntrySpan (EntrySpan)-import qualified Instana.SDK.Span.EntrySpan as EntrySpan-import           Instana.SDK.Span.ExitSpan  (ExitSpan)-import qualified Instana.SDK.Span.ExitSpan  as ExitSpan+import           Instana.SDK.Internal.Id              (Id)+import           Instana.SDK.Internal.W3CTraceContext (W3CTraceContext)+import           Instana.SDK.Span.EntrySpan           (EntrySpan)+import qualified Instana.SDK.Span.EntrySpan           as EntrySpan+import           Instana.SDK.Span.ExitSpan            (ExitSpan)+import qualified Instana.SDK.Span.ExitSpan            as ExitSpan   -- |The span kind (entry, exit or intermediate).@@ -181,6 +186,49 @@   case span_ of     Entry entry ->       Entry $ EntrySpan.setCorrelationId correlationId_ entry+    Exit _ ->+      span_+++-- |The W3C Trace Context. An entry span only has an associated W3C trace+-- context, if W3C trace context headers have been received. In contrast,+-- exit spans always have an associated W3C trace context.+w3cTraceContext :: Span -> Maybe W3CTraceContext+w3cTraceContext span_ =+  case span_ of+    Entry entry -> EntrySpan.w3cTraceContext entry+    Exit exit   -> Just $ ExitSpan.w3cTraceContext exit+++-- |Attaches a W3C trace context to the span.+setW3cTraceContext :: W3CTraceContext -> Span -> Span+setW3cTraceContext w3cTraceContext_ span_ =+  case span_ of+    Entry entry ->+      Entry $ EntrySpan.setW3cTraceContext w3cTraceContext_ entry+    Exit exit ->+      Exit $ ExitSpan.setW3cTraceContext w3cTraceContext_ exit+++-- |The span.tp flag. A span with span.tp = True has inherited the trace ID/+-- parent ID from W3C trace context instead of Instana headers. Only valid for+-- non-root entry spans.+tpFlag :: Span -> Bool+tpFlag span_ =+  case span_ of+    Entry entry -> EntrySpan.tpFlag entry+    Exit _      -> False+++-- |Set the span.tp flag. A span with span.tp = True has inherited the trace ID/+-- parent ID from W3C trace context instead of Instana headers. Only valid for+-- non-root entry spans, will be silently ignored for root entry spans and exit+-- spans.+setTpFlag :: Span -> Span+setTpFlag span_ =+  case span_ of+    Entry entry ->+      Entry $ EntrySpan.setTpFlag entry     Exit _ ->       span_ 

@@ -9,19 +9,27 @@   , TracingLevel(..)   , levelHeaderName   , parseXInstanaL+  , readHttpTracingHeaders   , spanIdHeaderName   , stringToTracingLevel   , syntheticHeaderName   , traceIdHeaderName+  , traceparentHeaderName+  , tracestateHeaderName   , tracingLevelToString   ) where  +import qualified Data.ByteString.Char8     as BSC8+import qualified Data.List                 as List import           GHC.Generics import qualified Network.HTTP.Types.Header as HTTPHeader+import qualified Network.Wai               as Wai import           Text.Regex.PCRE           ((=~)) +import           Instana.SDK.Internal.Util ((|>)) + -- |X-INSTANA-T traceIdHeaderName :: HTTPHeader.HeaderName traceIdHeaderName = "X-INSTANA-T"@@ -42,6 +50,16 @@ syntheticHeaderName = "X-INSTANA-SYNTHETIC"  +-- |traceparent+traceparentHeaderName :: HTTPHeader.HeaderName+traceparentHeaderName = "traceparent"+++-- |tracestate+tracestateHeaderName :: HTTPHeader.HeaderName+tracestateHeaderName = "tracestate"++ -- |Tracing level. data TracingLevel =     -- |Record calls.@@ -114,5 +132,57 @@     , correlationId   :: Maybe String       -- |synthetic flag     , synthetic       :: Bool+      -- |W3C Trace Context traceparent+    , traceparent     :: Maybe String+      -- |W3C Trace Context tracestate+    , tracestate      :: Maybe String     } deriving (Eq, Generic, Show)+++-- |Reads the Instana tracing headers+-- (https://docs.instana.io/core_concepts/tracing/#http-tracing-headers) from+-- the given request.+readHttpTracingHeaders :: Wai.Request -> TracingHeaders+readHttpTracingHeaders request =+  let+    headers = Wai.requestHeaders request+    -- lookup is automatically case insensitive because+    -- HeaderName = CI ByteString (CI -> Case Insensitive String)+    tId =+      headers+      |> List.lookup traceIdHeaderName+      |> (<$>) BSC8.unpack+    sId =+      headers+      |> List.lookup spanIdHeaderName+      |> (<$>) BSC8.unpack+    xInstanaLValue =+      headers+      |> List.lookup levelHeaderName+      |> (<$>) BSC8.unpack+    (lvl, crtp, crid) =+      parseXInstanaL xInstanaLValue+    sy =+      headers+      |> List.lookup syntheticHeaderName+      |> (<$>) BSC8.unpack+    tp =+      headers+      |> List.lookup traceparentHeaderName+      |> (<$>) BSC8.unpack+    ts =+      headers+      |> List.lookup tracestateHeaderName+      |> (<$>) BSC8.unpack+  in+  TracingHeaders+    { traceId = tId+    , spanId = sId+    , level = lvl+    , correlationType = crtp+    , correlationId = crid+    , synthetic = sy == (Just "1")+    , traceparent = tp+    , tracestate = ts+    } 

@@ -1,10 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}-module Instana.SDK.IntegrationTest.BracketApi-  ( shouldRecordSpans-  , shouldRecordNonRootEntry-  , shouldMergeTags-  , shouldSetServiceName-  ) where+module Instana.SDK.IntegrationTest.BracketApi (allTests) where   import           Data.Aeson                             ((.=))@@ -16,11 +11,20 @@  import           Instana.SDK.AgentStub.TraceRequest     (From (..)) import qualified Instana.SDK.AgentStub.TraceRequest     as TraceRequest-import qualified Instana.SDK.IntegrationTest.HttpHelper as HttpHelper import           Instana.SDK.IntegrationTest.HUnitExtra (applyLabel,                                                          assertAllIO, failIO)+import qualified Instana.SDK.IntegrationTest.HttpHelper as HttpHelper import qualified Instana.SDK.IntegrationTest.Suite      as Suite import qualified Instana.SDK.IntegrationTest.TestHelper as TestHelper+++allTests :: String -> [IO Test]+allTests pid =+  [ shouldRecordSpans pid+  , shouldRecordNonRootEntry pid+  , shouldMergeTags pid+  , shouldSetServiceName pid+  ]   shouldRecordSpans ::  String -> IO Test

@@ -1,8 +1,9 @@ module Instana.SDK.IntegrationTest.HUnitExtra-  ( applyLabel+  ( SuiteResult+  , applyLabel   , assertAllIO   , failIO-  , mergeCounts+  , mergeTestResults   , passIO   , skip   ) where@@ -10,7 +11,9 @@  import qualified Data.List                           as List import           System.Log.Logger                   (infoM)-import           Test.HUnit+import           Test.HUnit                          (Assertion, Counts (..),+                                                      Test (..), assertBool,+                                                      assertFailure)  import           Instana.SDK.IntegrationTest.Logging (testLogger) @@ -42,21 +45,39 @@   return $ TestLabel label $ TestList []  -mergeCounts :: [Counts] -> Counts-mergeCounts =-  List.foldl-    addCounts-    (Counts { cases = 0, tried = 0, errors = 0, failures = 0 })+type SuiteResult = (Counts, [String])  -addCounts :: Counts -> Counts -> Counts-addCounts c1 c2 =-  Counts-    { cases = cases c1 + cases c2-    , tried = tried c1 + tried c2-    , errors = errors c1 + errors c2-    , failures = failures c1 + failures c2-    }+mergeTestResults :: [SuiteResult] -> SuiteResult+mergeTestResults allResults =+  let+    (counts_, fullReport) =+      List.foldl+        merge+        ( (Counts+            { cases = 0+            , tried = 0+            , errors = 0+            , failures = 0+            }+          )+        , []+        )+        allResults+  in+  (counts_, fullReport)+++merge :: SuiteResult -> SuiteResult -> SuiteResult+merge (counts1, report1) (counts2, report2) =+  ( Counts+      { cases = cases counts1 + cases counts2+      , tried = tried counts1 + tried counts2+      , errors = errors counts1 + errors counts2+      , failures = failures counts1 + failures counts2+      }+  , report1 ++ report2+  )   

@@ -1,18 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}-module Instana.SDK.IntegrationTest.HttpTracing-  ( shouldCreateRootEntryWithBracketApi-  , shouldAddWebsiteMonitoringCorrelationWithBracketApi-  , shouldIgnoreTraceIdParentIdIfWebsiteMonitoringCorrelationIsPresentWithBracketApi-  , shouldCreateNonRootEntryWithBracketApi-  , shouldSetSpanSyWithBracketApi-  , shouldSuppressWithBracketApi-  , shouldCreateRootEntryWithLowLevelApi-  , shouldAddWebsiteMonitoringCorrelationWithLowLevelApi-  , shouldIgnoreTraceIdParentIdIfWebsiteMonitoringCorrelationIsPresentWithLowLevelApi-  , shouldCreateNonRootEntryWithLowLevelApi-  , shouldSetSpanSyWithLowLevelApi-  , shouldSuppressWithLowLevelApi-  ) where+module Instana.SDK.IntegrationTest.HttpTracing (allTests) where   import           Control.Concurrent                     (threadDelay)@@ -36,6 +23,23 @@ import           Test.HUnit  +allTests :: String -> [IO Test]+allTests pid =+  [ shouldCreateRootEntryWithBracketApi pid+  , shouldAddWebsiteMonitoringCorrelationWithBracketApi pid+  , shouldIgnoreTraceIdParentIdIfWebsiteMonitoringCorrelationIsPresentWithBracketApi pid+  , shouldCreateNonRootEntryWithBracketApi pid+  , shouldSetSpanSyWithBracketApi pid+  , shouldSuppressWithBracketApi+  , shouldCreateRootEntryWithLowLevelApi pid+  , shouldAddWebsiteMonitoringCorrelationWithLowLevelApi pid+  , shouldIgnoreTraceIdParentIdIfWebsiteMonitoringCorrelationIsPresentWithLowLevelApi pid+  , shouldCreateNonRootEntryWithLowLevelApi pid+  , shouldSetSpanSyWithLowLevelApi pid+  , shouldSuppressWithLowLevelApi+  ]++ shouldCreateRootEntryWithBracketApi :: String -> IO Test shouldCreateRootEntryWithBracketApi pid =   applyLabel "shouldCreateRootEntryWithBracketApi" $@@ -232,8 +236,8 @@       [("X-INSTANA-L", "0")]   let     responseBody = LBSC8.unpack $ HTTP.responseBody response-  -- wait a second, then check that no spans have been recorded-  threadDelay $ 10 * 1000+  -- wait a few seconds, then check that no spans have been recorded+  threadDelay $ 5 * 1000 * 1000   spansResults <-     TestHelper.waitForRegisteredSpansMatching []   case spansResults of

@@ -1,9 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}-module Instana.SDK.IntegrationTest.LowLevelApi-  ( shouldRecordSpans-  , shouldRecordNonRootEntry-  , shouldMergeTags-  ) where+module Instana.SDK.IntegrationTest.LowLevelApi (allTests) where   import           Data.Aeson                             ((.=))@@ -15,11 +11,19 @@  import           Instana.SDK.AgentStub.TraceRequest     (From (..)) import qualified Instana.SDK.AgentStub.TraceRequest     as TraceRequest-import qualified Instana.SDK.IntegrationTest.HttpHelper as HttpHelper import           Instana.SDK.IntegrationTest.HUnitExtra (applyLabel,                                                          assertAllIO, failIO)+import qualified Instana.SDK.IntegrationTest.HttpHelper as HttpHelper import qualified Instana.SDK.IntegrationTest.Suite      as Suite import qualified Instana.SDK.IntegrationTest.TestHelper as TestHelper+++allTests :: String -> [IO Test]+allTests pid =+  [ shouldRecordSpans pid+  , shouldRecordNonRootEntry pid+  , shouldMergeTags pid+  ]   shouldRecordSpans :: String -> IO Test

@@ -51,7 +51,7 @@               (EntityDataRequest.arguments entityData)           , assertLabelIs               "sensorVersion"-              "0.6.2.0"+              "0.7.0.0"               (EntityDataRequest.sensorVersion entityData)           , assertCounterSatisfies               "startTime"

@@ -5,15 +5,21 @@ import qualified Data.ByteString.Lazy.Char8             as LBSC8 import           Data.List                              as List import qualified Data.Maybe                             as Maybe+import qualified Data.Text                              as T import qualified Network.HTTP.Client                    as HTTP import           System.Environment                     (lookupEnv) import           System.Exit                            as Exit import           System.Log.Logger                      (infoM) import           System.Process                         as Process-import           Test.HUnit+import           Test.HUnit                             (Counts (Counts),+                                                         Test (TestLabel, TestList),+                                                         assertFailure)+import qualified Test.HUnit                             as HUnit+import qualified Test.HUnit.Text                        as HUnitText +import           Instana.SDK.IntegrationTest.HUnitExtra (SuiteResult,+                                                         mergeTestResults) import qualified Instana.SDK.IntegrationTest.HttpHelper as HttpHelper-import           Instana.SDK.IntegrationTest.HUnitExtra (mergeCounts) import           Instana.SDK.IntegrationTest.Logging    (testLogger) import           Instana.SDK.IntegrationTest.Suite      (AppUnderTest,                                                          ConditionalSuite (..),@@ -46,29 +52,50 @@       "Running " ++ show (List.length allSuites) ++ " test suite(s)."   results <- sequence actions   let-    mergedResults = mergeCounts results-    caseCount = cases mergedResults + skippedDueToExlusive-    triedCount = tried mergedResults-    errCount = errors mergedResults-    failCount = failures mergedResults-  infoM testLogger $+    (mergedCounts, mergedReport) = mergeTestResults results+    caseCount = HUnit.cases mergedCounts + skippedDueToExlusive+    triedCount = HUnit.tried mergedCounts+    errCount = HUnit.errors mergedCounts+    failCount = HUnit.failures mergedCounts+  if errCount > 0 && failCount > 0 then do+    logReport mergedReport+    logSummary caseCount triedCount errCount failCount+    Exit.die "😱 😭 There have been errors and failures! 😱 😭"+  else if errCount > 0 then do+    logReport mergedReport+    logSummary caseCount triedCount errCount failCount+    Exit.die "😱 There have been errors! 😱"+  else if failCount > 0 then do+    logReport mergedReport+    logSummary caseCount triedCount errCount failCount+    Exit.die "😭 There have been test failures. 😭"+  else do+    logSummary caseCount triedCount errCount failCount+    infoM testLogger "🎉 All tests have passed. 🎉"+  return mergedCounts+++logReport :: [String] -> IO ()+logReport report = do+  _ <- sequence $+    map+      (\reportLine -> infoM testLogger reportLine)+      ("COLLECTED FAILURES:" : report)+  return ()+++logSummary :: Int -> Int -> Int -> Int -> IO ()+logSummary caseCount triedCount errCount failCount =+ infoM testLogger $     "SUMMARY: Cases: " ++ show caseCount ++     "  Tried: " ++ show triedCount ++     "  Errors: " ++ show errCount ++     "  Failures: " ++ show failCount-  if errCount > 0 && failCount > 0 then-    Exit.die "😱 😭 There have been errors and failures! 😱 😭"-  else if errCount > 0 then-    Exit.die "😱 There have been errors! 😱"-  else if failCount > 0 then-    Exit.die "😭 There have been test failures. 😭"-  else infoM testLogger "🎉 All tests have passed. 🎉"-  return mergedResults   {-| Runs the suite unless it is skipped. -}-runConditionalSuite :: ConditionalSuite -> IO Counts+runConditionalSuite :: ConditionalSuite -> IO SuiteResult runConditionalSuite conditionalSuite = do   case conditionalSuite of     Run suite       ->@@ -76,12 +103,12 @@     Exclusive suite ->       runSuite suite     Skip _          ->-      return $ Counts 1 0 0 0+      return $ (Counts 1 0 0 0, [])   {-| Starts the app under test and the agent stub, then runs the test suite. -}-runSuite :: Suite -> IO Counts+runSuite :: Suite -> IO SuiteResult runSuite suite = do   let     suiteLabel = Suite.label suite@@ -109,6 +136,8 @@             [ ("APP_LOG_LEVEL", Just logLevel)             , ("INSTANA_SERVICE_NAME", Suite.customServiceName options)             , ("INSTANA_LOG_LEVEL", Just logLevel)+            , ("INSTANA_DISABLE_W3C_TRACE_CORRELATION",+               booleanEnv $ Suite.disableW3cTraceCorrelation options)             ]             "stack exec " ++ (Suite.executable appUnderTest)         )@@ -136,7 +165,7 @@     )  -runTests :: Suite -> IO Counts+runTests :: Suite -> IO SuiteResult runTests suite = do   infoM testLogger "⏱  waiting for agent stub to come up"   _ <- HttpHelper.retryRequestRecovering TestHelper.pingAgentStub@@ -187,7 +216,7 @@  -- |Waits for the app under test to establish a connection to the agent, then -- runs the tests of the given suite.-waitForAgentConnectionAndRun :: Suite -> Int -> IO Counts+waitForAgentConnectionAndRun :: Suite -> Int -> IO SuiteResult waitForAgentConnectionAndRun suite appPid = do   let     options = Suite.options suite@@ -204,10 +233,44 @@       runTestSuite pid suite  -runTestSuite :: String -> Suite -> IO Counts+collectReport :: HUnit.PutText (Int, [String])+collectReport = HUnit.PutText addToReport (0, [])+++-- inspired by+-- https://hackage.haskell.org/package/HUnit-1.6.2.0/docs/src/Test.HUnit.Text.html#putTextToHandle+-- to avoid excessive output of progress lines+-- Cases/Tried/Errors/Failures lines, while adding the capability to collect+-- report lines for printing a summary after all suites have been ran.+addToReport :: String -> Bool -> (Int, [String]) -> IO (Int, [String])+-- persistent test report lines, print and collect+addToReport line True (cnt, lines_) = do+  putStrLn (erase cnt ++ line);+  if T.isPrefixOf (T.pack "Cases: ") (T.pack line) then+    -- Do not collect the test progress lines "Cases: 24 Tried: 24 ..."+    return $ (0, lines_)+  else+    -- Collect everything else, most importantly, detailed info about+    -- failed assertions+    return $ (0, lines_ ++ [line])+-- non-persistent progress lines, print but don't collect+addToReport line False (_, lines_) = do+  putStr ('\r' : line)+  return (length line, lines_)+++erase :: Int -> String+erase cnt =+  if cnt == 0 then "" else "\r" ++ replicate cnt ' ' ++ "\r"+++runTestSuite :: String -> Suite -> IO SuiteResult runTestSuite pid suite = do   integrationTestsIO <- wrapSuite pid suite-  runTestTT integrationTestsIO+  (counts, (_, report)) <- HUnitText.runTestText+    collectReport+    integrationTestsIO+  return (counts, report)   wrapSuite :: String -> Suite -> IO Test

@@ -1,7 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}-module Instana.SDK.IntegrationTest.ServiceName-  ( shouldUseServiceNameEnvVar-  ) where+module Instana.SDK.IntegrationTest.ServiceName (allTests) where   import           Data.Aeson                             ((.=))@@ -13,11 +11,17 @@  import           Instana.SDK.AgentStub.TraceRequest     (From (..)) import qualified Instana.SDK.AgentStub.TraceRequest     as TraceRequest-import qualified Instana.SDK.IntegrationTest.HttpHelper as HttpHelper import           Instana.SDK.IntegrationTest.HUnitExtra (applyLabel,                                                          assertAllIO, failIO)+import qualified Instana.SDK.IntegrationTest.HttpHelper as HttpHelper import qualified Instana.SDK.IntegrationTest.Suite      as Suite import qualified Instana.SDK.IntegrationTest.TestHelper as TestHelper+++allTests :: String -> [IO Test]+allTests pid =+  [ shouldUseServiceNameEnvVar pid+  ]   shouldUseServiceNameEnvVar :: String -> IO Test

@@ -0,0 +1,1041 @@+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Instana.SDK.IntegrationTest.SpecCompliance+  ( allTestsW3cCorrelationOn+  , allTestsW3cCorrelationOff+  ) where+++import           Control.Concurrent                     (threadDelay)+import           Data.Aeson                             ((.:), (.:?), (.=))+import qualified Data.Aeson                             as Aeson+import           Data.Aeson.Types                       (FromJSON)+import qualified Data.Aeson.Types                       as AesonTypes+import           Data.Array                             ((!))+import qualified Data.Array                             as Array+import qualified Data.ByteString.Char8                  as BSC8+import qualified Data.ByteString.Lazy.Char8             as LBSC8+import qualified Data.CaseInsensitive                   as CI+import           Data.HashMap.Strict                    (HashMap)+import qualified Data.HashMap.Strict                    as HashMap+import           Data.Maybe                             (catMaybes, 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)+import qualified Instana.SDK.AgentStub.TraceRequest     as TraceRequest+import           Instana.SDK.IntegrationTest.HUnitExtra (applyLabel,+                                                         assertAllIO, failIO)+import qualified Instana.SDK.IntegrationTest.HttpHelper as HttpHelper+import           Instana.SDK.IntegrationTest.Suite      (AppUnderTest)+import qualified Instana.SDK.IntegrationTest.TestHelper as TestHelper+import qualified Network.HTTP.Client                    as HTTP+import           Network.HTTP.Types                     (Header)+import qualified Network.HTTP.Types.Header+import           Test.HUnit+import qualified Text.Regex.Base.RegexLike              as RegexBase+import           Text.Regex.TDFA.String                 (Regex)+++data RunSubsetOfCases =+    RunAll+  | RunSubset [Int]+++testCasesToRun :: RunSubsetOfCases+testCasesToRun = RunAll+++allTestsW3cCorrelationOn ::+  Aeson.Array+  -> AppUnderTest+  -> String+  -> String+  -> [IO Test]+allTestsW3cCorrelationOn+    specificationComplianceTestCases+    appUnderTest+    route+    pid = do+  jsonToTestCases+    appUnderTest+    False+    route+    pid+    specificationComplianceTestCases+++allTestsW3cCorrelationOff ::+  Aeson.Array+  -> AppUnderTest+  -> String+  -> String+  -> [IO Test]+allTestsW3cCorrelationOff+    specificationComplianceTestCases+    appUnderTest+    route+    pid =+  jsonToTestCases+    appUnderTest+    True+    route+    pid+    specificationComplianceTestCases+++data SpecTestCase = SpecTestCase+  { index                 :: Int+  , scenario              :: String+  , whatToDo              :: String+  , disableW3cCorrelation :: Maybe Text+  , xInstanaTIn           :: Maybe String+  , xInstanaSIn           :: Maybe String+  , xInstanaLIn           :: Maybe String+  , xInstanaSyntheticIn   :: Maybe String+  , traceparentIn         :: Maybe String+  , tracestateIn          :: Maybe String+  , serverTiming          :: Maybe String+  , entrySpanT            :: Maybe String+  , entrySpanP            :: Maybe String+  , entrySpanS            :: Maybe String+  , entrySpanIa           :: Maybe InstanaAncestor+  , entrySpanTp           :: Maybe Bool+  , entrySpanLt           :: Maybe String+  , entrySpanCrid         :: Maybe String+  , entrySpanCrtp         :: Maybe String+  , entrySpanSy           :: Maybe Bool+  , exitSpanT             :: Maybe String+  , exitSpanP             :: Maybe String+  , exitSpanS             :: Maybe String+  , exitSpanIa            :: Maybe InstanaAncestor+  , exitSpanTp            :: Maybe Bool+  , exitSpanLt            :: Maybe String+  , exitSpanCrid          :: Maybe String+  , exitSpanCrtp          :: Maybe String+  , exitSpanSy            :: Maybe Bool+  , xInstanaTOut          :: Maybe String+  , xInstanaSOut          :: Maybe String+  , xInstanaLOut          :: Maybe String+  , traceparentOut        :: Maybe String+  , tracestateOut         :: Maybe String+  }+  deriving (Show)+++instance FromJSON SpecTestCase where+  parseJSON = Aeson.withObject "Spec Test Case" $+    \obj ->+      SpecTestCase+        <$> obj .: "index"+        <*> obj .: "Scenario/incoming headers"+        <*> obj .: "What to do?"+        <*> obj .:? "INSTANA_DISABLE_W3C_TRACE_CORRELATION"+        <*> obj .:? "X-INSTANA-T in"+        <*> obj .:? "X-INSTANA-S in"+        <*> obj .:? "X-INSTANA-L in"+        <*> obj .:? "X-INSTANA-SYNTHETIC in"+        <*> obj .:? "traceparent in"+        <*> obj .:? "tracestate in"+        <*> obj .:? "Server-Timing"+        <*> obj .:? "entrySpan.t"+        <*> obj .:? "entrySpan.p"+        <*> obj .:? "entrySpan.s"+        <*> obj .:? "entrySpan.ia"+        <*> obj .:? "entrySpan.tp"+        <*> obj .:? "entrySpan.lt"+        <*> obj .:? "entrySpan.crid"+        <*> obj .:? "entrySpan.crtp"+        <*> obj .:? "entrySpan.sy"+        <*> obj .:? "exitSpan.t"+        <*> obj .:? "exitSpan.p"+        <*> obj .:? "exitSpan.s"+        <*> obj .:? "exitSpan.ia"+        <*> obj .:? "exitSpan.tp"+        <*> obj .:? "exitSpan.lt"+        <*> obj .:? "exitSpan.crid"+        <*> obj .:? "exitSpan.crtp"+        <*> obj .:? "exitSpan.sy"+        <*> obj .:? "X-INSTANA-T out"+        <*> obj .:? "X-INSTANA-S out"+        <*> obj .:? "X-INSTANA-L out"+        <*> obj .:? "traceparent out"+        <*> obj .:? "tracestate out"+++type ValueForPlaceholder = (Text, Text)+++type ValuesForPlaceholders = [ValueForPlaceholder]+++type TestContext = ([Assertion], ValuesForPlaceholders)+++addAssertion :: Assertion -> TestContext -> TestContext+addAssertion newAssertion (existingAssertions, valuesForPlaceholders) =+  (existingAssertions ++ [newAssertion], valuesForPlaceholders)+++addAssertions :: [Assertion] -> TestContext -> TestContext+addAssertions newAssertions (existingAssertions, valuesForPlaceholders) =+  (existingAssertions ++ newAssertions, valuesForPlaceholders)+++addPlaceholderValue :: ValueForPlaceholder -> TestContext -> TestContext+addPlaceholderValue newValue (assertions, valuesForPlaceholders) =+  (assertions, valuesForPlaceholders ++ [newValue])+++data ExpectedActual =+    S String+  | MS (Maybe String)+  | MIA (Maybe InstanaAncestor)+  | MB (Maybe Bool)+++instance Eq ExpectedActual where+  S s1 == S s2 =+    s1 == s2+  S s1 == MS (Just s2) =+    s1 == s2+  S _ == MS Nothing =+    False+  MS ms1 == S s2 =+    S s2 == MS ms1+  S _ == MIA _ =+    False+  MIA _ == S _ =+    False+  S _ == MB _ =+    False+  MB _ == S _ =+    False+  MS ms1 == MS ms2 =+    ms1 == ms2+  MS _ == MIA _ =+    False+  MIA _ == MS _ =+    False+  MS _ == MB _ =+    False+  MB _ == MS _ =+    False+  MIA mia1 == MIA mia2 =+    mia1 == mia2+  MIA _ == MB _ =+    False+  MB _ == MIA _ =+    False+  MB mb1 == MB mb2 =+    mb1 == mb2+++instance Show ExpectedActual where+  show (S s)    = show s+  show (MS ms)  = show ms+  show (MIA ia) = show ia+  show (MB mb)  = show mb+++unpack :: ExpectedActual -> String+unpack (S s)         = s+unpack (MS (Just s)) = s+unpack (MS Nothing)  = "Nothing"+unpack (MIA ia)      = show ia+unpack (MB mb)       = show mb+++jsonToTestCases ::+  AppUnderTest+  -> Bool+  -> String+  -> String+  -> Aeson.Array+  -> [IO Test]+jsonToTestCases+    appUnderTest+    w3cCorrelationDisabled+    route+    pid+    allTestCaseAsJson = do+  let+    testCasesDefinitionAesonValues = Vector.toList allTestCaseAsJson+    testCasesDefinitionEitherValues :: [Either String SpecTestCase]+    testCasesDefinitionEitherValues =+      map jsonToTestCaseDefinition testCasesDefinitionAesonValues+    testCasesDefinitions :: [SpecTestCase]+    testCasesDefinitions =+      map+        (\testCaseDefinitionEither ->+          case testCaseDefinitionEither of+            Left errorMessage ->+              -- Could not parse JSON to test case definition.+              -- Because we are lazy, we just let the test suite crash :-)+              error errorMessage+            Right testCaseDefinition ->+              testCaseDefinition+        )+        testCasesDefinitionEitherValues+    testCaseDefinitionsForW3cDisabledSetting :: [SpecTestCase]+    testCaseDefinitionsForW3cDisabledSetting =+      filter+        (\testCaseDefinition ->+          if w3cCorrelationDisabled then+            case disableW3cCorrelation testCaseDefinition of+              Just value ->+                not $ T.null value+              Nothing ->+                False+          else+            case disableW3cCorrelation testCaseDefinition of+              Just value ->+                T.null value+              Nothing ->+                True+        )+        testCasesDefinitions+    testCaseDefinitionsFiltered :: [SpecTestCase]+    testCaseDefinitionsFiltered =+      case testCasesToRun of+        RunAll -> testCaseDefinitionsForW3cDisabledSetting+        RunSubset subset ->+          filter+            (\testCaseDefinition ->+              elem (index testCaseDefinition) subset+            )+            testCaseDefinitionsForW3cDisabledSetting+  map+    (testCaseDefinitionToTest appUnderTest route pid)+    testCaseDefinitionsFiltered+++jsonToTestCaseDefinition :: Aeson.Value -> Either String SpecTestCase+jsonToTestCaseDefinition testCaseAsJson =+  AesonTypes.parseEither+    Aeson.parseJSON+    testCaseAsJson :: Either String SpecTestCase+++testCaseDefinitionToTest ::+  AppUnderTest+  -> String+  -> String+  -> SpecTestCase+  -> IO Test+testCaseDefinitionToTest appUnderTest route pid testCaseDefinition = do+  let+    label =+      (show $ index testCaseDefinition) ++ ": " +++      scenario testCaseDefinition ++ " -> " +++      whatToDo testCaseDefinition+    headers = testCaseDefinitionToHeaders testCaseDefinition+  putStrLn $ "Creating test: " ++ label ++ "\nwith headers:\n" ++ show headers+  putStrLn $ "TEST CASE: " ++ show testCaseDefinition+  applyLabel label $+    runSpecTestCase+      appUnderTest+      route+      pid+      headers+      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)+      ]+  where+    toHeader (_, Nothing)       = Nothing+    toHeader (name, Just value) = Just (name, BSC8.pack value)+++runSpecTestCase ::+  AppUnderTest+  -> String+  -> String+  -> [Header]+  -> SpecTestCase+  -> IO Test+runSpecTestCase appUnderTest route pid headers testCaseDefinition = do+  let+    suppressionHeader =+      filter+        (\(name, value) ->+          (name == (CI.mk (BSC8.pack "X-INSTANA-L"))) &&+          (value == BSC8.pack "0")+        )+        headers+    suppressed =+      (length suppressionHeader) >= 1+  executeRequestAndVerify+    appUnderTest+    testCaseDefinition+    route+    pid+    suppressed+    headers+++executeRequestAndVerify ::+  AppUnderTest+  -> SpecTestCase+  -> String+  -> String+  -> Bool+  -> [Header]+  -> IO Test+executeRequestAndVerify+  appUnderTest+  testCaseDefinition+  route+  pid+  suppressed+  headers = do+  response <-+    HttpHelper.doAppRequest+      appUnderTest+      (route ++ "?some=query&parameters=1")+      "GET"+      headers+  let+    initialTestContext = ([], [])++    testContextAfterServerTimingCheck =+       verifyServerTimingHeader+         testCaseDefinition+         initialTestContext+         response++    eitherResponseBody =+      Aeson.eitherDecode' $ HTTP.responseBody response++    from = Just $ From pid "agent-stub-id"++  case eitherResponseBody of+    Right responseBody -> do+      let+        testContextAfterDownstreamHeaderCheck =+           verifyHttpHeadersOnDownstreamRequest+             testCaseDefinition+             testContextAfterServerTimingCheck+             responseBody++      case suppressed of++        False ->+          verifySpans+            testCaseDefinition+            testContextAfterDownstreamHeaderCheck+            route+            responseBody+            from++        True ->+          verifySuppression testContextAfterDownstreamHeaderCheck++    Left decodeError ->+      failIO $ "Could decode HTTP response body: " ++ decodeError+++verifyServerTimingHeader ::+  SpecTestCase+  -> TestContext+  -> HTTP.Response LBSC8.ByteString+  -> TestContext+verifyServerTimingHeader testCaseDefinition testContext response =+  let+    responseHeaders = HTTP.responseHeaders response+    serverTimingTuple ::+      Maybe (Network.HTTP.Types.Header.HeaderName, BSC8.ByteString)+    serverTimingTuple =+      listToMaybe $+        filter+          (\ (headerName, _) -> headerName == "Server-Timing")+          responseHeaders+    actualServerTimingValueM = BSC8.unpack <$> (snd <$> serverTimingTuple)+    expectedServerTimingValueM = serverTiming testCaseDefinition+  in+  case (expectedServerTimingValueM, actualServerTimingValueM) of+    (Just expectedServerTimingValue, Just actualServerTimingValue) ->+      if containsPlaceholder expectedServerTimingValue then+        parseForPlaceholders+          testContext+          "Server-Timing header"+          expectedServerTimingValue+          actualServerTimingValue+      else+        addAssertion+          (assertEqual "Server-Timing header"+             expectedServerTimingValue+             actualServerTimingValue+          )+          testContext++    (Just expectedServerTimingValue, Nothing)  ->+      addAssertion+        (assertFailure $ "Expected Server-Timing header " +++           expectedServerTimingValue ++ ", but got nothing."+        )+        testContext++    (Nothing, Just actualServerTimingValue)  ->+      addAssertion+        (assertFailure $ "Expected no Server-Timing header, but got " +++            actualServerTimingValue ++ "."+        )+        testContext++    (Nothing, Nothing)  ->+      testContext+++verifyHttpHeadersOnDownstreamRequest ::+  SpecTestCase+  -> TestContext+  -> HashMap Text AesonTypes.Value+  -> TestContext+verifyHttpHeadersOnDownstreamRequest+  testCaseDefinition+  testContext+  responseBody =+  let+    testContextAfterXInstanaLCheck =+      addAssertion+        (xInstanaLAssertion responseBody testCaseDefinition)+        testContext+  in+  foldr+    (\(header, accessor) currentTestContext ->+      let+        message =+          "value for downstream HTTP header " ++ (T.unpack header)+        expectedValueM :: Maybe String+        expectedValueM = accessor testCaseDefinition+      in+      case expectedValueM of++        Just expectedValue ->+          if containsPlaceholder expectedValue then+            parseForPlaceholderJsonValue+              currentTestContext+              message+              expectedValue+              (HashMap.lookup header responseBody)+          else+            addAssertion+              (assertEqualInMap message expectedValue header responseBody)+              currentTestContext+        Nothing ->+          addAssertion+            (assertNotInMap message header responseBody)+            currentTestContext+    )+    testContextAfterXInstanaLCheck+    [ ("X-INSTANA-T", xInstanaTOut)+    , ("X-INSTANA-S", xInstanaSOut)+    -- X-INSTANA-L is checked separately via xInstanaLAssertion+    , ("traceparent", traceparentOut)+    , ("tracestate", tracestateOut)+    ]+++xInstanaLAssertion :: HashMap Text AesonTypes.Value -> SpecTestCase -> Assertion+xInstanaLAssertion responseBody testCaseDefinition =+  case xInstanaLOut testCaseDefinition of+    Just "1" ->+      let+        actualValueM = HashMap.lookup "X-INSTANA-L" responseBody+      in+      assertBool "Expected X-INSTANA-L to be either absent or \"1\"" $+        (actualValueM == Nothing) || (actualValueM == (Just $ Aeson.String "1"))++    Just "0" ->+      assertEqualInMap+        "value for downstream HTTP header X-INSTANA-L"+        "0"+        "X-INSTANA-L"+        responseBody++    _ ->+      fail $+        "Unexpected expectation value for downstream X-INSTANA-L in test " +++        "case defintion: " +++        (show $ xInstanaLOut testCaseDefinition)+++verifySpans ::+  SpecTestCase+  -> TestContext+  -> String+  -> HashMap Text AesonTypes.Value+  -> Maybe From+  -> IO Test+verifySpans+  testCaseDefinition+  testContext+  route+  responseBody+  from = do+  spansResults <-+    TestHelper.waitForRegisteredSpansMatching+      [ "haskell.wai.server", "haskell.http.client" ]+  case spansResults of+    Left failure ->+      failIO $ "Could not load recorded spans from agent stub: " ++ failure+    Right spans -> do+      let+        maybeEntrySpan =+          TestHelper.getSpanByRegisteredName "haskell.wai.server" spans+        maybeExitSpan =+          TestHelper.getSpanByRegisteredName "haskell.http.client" spans+      if isNothing maybeEntrySpan || isNothing maybeExitSpan+        then+          failIO "expected spans have not been recorded"+        else do+          let+            Just entrySpan = maybeEntrySpan+            Just exitSpan = maybeExitSpan+            (assertions, _) =+              (spanAssertions+                testCaseDefinition+                testContext+                route+                entrySpan+                exitSpan+                from+              )+          putStrLn $ "ENTRY " ++ show entrySpan+          putStrLn $ "EXIT " ++ show exitSpan+          putStrLn $ "RESPONSE " ++ show responseBody+          assertAllIO $ assertions+++spanAssertions ::+  SpecTestCase+  -> TestContext+  -> String+  -> Span+  -> Span+  -> Maybe From+  -> TestContext+spanAssertions+  testCaseDefinition+  testContext+  route+  entrySpan+  exitSpan+  from =+  addAssertions+    (fixedSpanAssertions route entrySpan exitSpan from)+    (spanAssertionsFromTestCaseDefinition+        testCaseDefinition+        testContext+        entrySpan+        exitSpan+    )+++fixedSpanAssertions ::+  String+  -> Span+  -> Span+  -> Maybe From+  -> [Assertion]+fixedSpanAssertions route 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&parameters=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&parameters=2" :: String)+          , "status" .= (200 :: Int)+          ]+        )+      ]+    )+    (TraceRequest.spanData exitSpan)+  ]+++spanAssertionsFromTestCaseDefinition ::+  SpecTestCase+  -> TestContext+  -> Span+  -> Span+  -> TestContext+spanAssertionsFromTestCaseDefinition+  testCaseDefinition+  testContext+  entrySpan+  exitSpan =+  let+    testContextAfterEntrySpanChecks =+      verifyEntrySpan testCaseDefinition testContext entrySpan+  in+  verifyExitSpan testCaseDefinition testContextAfterEntrySpanChecks exitSpan+++verifyEntrySpan ::+  SpecTestCase+  -> TestContext+  -> Span+  -> TestContext+verifyEntrySpan testCaseDefinition testContext entrySpan =+  verifySpan testCaseDefinition testContext "entry" entrySpan $+    [ ( "t"   , MS  . entrySpanT    , S   . TraceRequest.t    )+    , ( "p"   , MS  . entrySpanP    , MS  . TraceRequest.p    )+    , ( "s"   , MS  . entrySpanS    , S   . TraceRequest.s    )+    , ( "ia"  , MIA . entrySpanIa   , MIA . TraceRequest.ia   )+    , ( "tp"  , MB  . entrySpanTp   , MB  . TraceRequest.tp   )+    , ( "lt"  , MS  . entrySpanLt   , MS  . TraceRequest.lt   )+    , ( "crid", MS  . entrySpanCrid , MS  . TraceRequest.crid )+    , ( "crtp", MS  . entrySpanCrtp , MS  . TraceRequest.crtp )+    , ( "sy"  , MB  . entrySpanSy   , MB  . TraceRequest.sy   )+    ]+++verifyExitSpan ::+  SpecTestCase+  -> TestContext+  -> Span+  -> TestContext+verifyExitSpan testCaseDefinition testContext exitSpan =+  verifySpan testCaseDefinition testContext "exit" exitSpan $+  [ ( "t"   , MS  . exitSpanT    , S   . TraceRequest.t    )+  , ( "p"   , MS  . exitSpanP    , MS  . TraceRequest.p    )+  , ( "s"   , MS  . exitSpanS    , S   . TraceRequest.s    )+  , ( "ia"  , MIA . exitSpanIa   , MIA . TraceRequest.ia   )+  , ( "tp"  , MB  . exitSpanTp   , MB  . TraceRequest.tp   )+  , ( "lt"  , MS  . exitSpanLt   , MS  . TraceRequest.lt   )+  , ( "crid", MS  . exitSpanCrid , MS  . TraceRequest.crid )+  , ( "crtp", MS  . exitSpanCrtp , MS  . TraceRequest.crtp )+  , ( "sy"  , MB  . exitSpanSy   , MB  . TraceRequest.sy   )+  ]+++verifySpan ::+  SpecTestCase+  -> TestContext+  -> String+  -> Span+  -> [(String, SpecTestCase -> ExpectedActual, Span -> ExpectedActual)]+  -> TestContext+verifySpan testCaseDefinition testContext spanKindLabel span_ accessorPairs =+  foldr+    (\(attributeLabel, testCaseAccesor, spanAccesor) currentTestContext ->+      let+        label = spanKindLabel ++ " span." ++ attributeLabel+        expectedValue = testCaseAccesor testCaseDefinition+        actualValue = spanAccesor span_+      in+      if containsPlaceholder' expectedValue then+        parseForPlaceholders+          currentTestContext+          label+          (unpack expectedValue)+          (unpack actualValue)+      else+        addAssertion+          (assertEqual+            label+            expectedValue+            actualValue+          )+          currentTestContext+    )+    testContext+    accessorPairs+++verifySuppression ::+  TestContext+  -> IO Test+verifySuppression (assertions, _) = do+  -- wait a few seconds, then check that no spans have been recorded+  threadDelay $ 5 * 1000 * 1000+  spansResults <-+    TestHelper.waitForRegisteredSpansMatching []+  case spansResults of+    Left failure ->+      failIO $ "Could not load recorded spans from agent stub: " ++ failure+    Right spans -> do+      if not (null spans)+        then+          failIO "spans have been recorded although they should have not"+        else+          assertAllIO $ assertions+++containsPlaceholder :: String -> Bool+containsPlaceholder = elem '$'+++containsPlaceholder' :: ExpectedActual -> Bool+containsPlaceholder' (S s)         = elem '$' s+containsPlaceholder' (MS (Just s)) = elem '$' s+containsPlaceholder' (MS Nothing)  = False+containsPlaceholder' (MIA _)       = False+containsPlaceholder' (MB _)        = False+++parseForPlaceholders ::+  TestContext+  -> String+  -> String+  -> String+  -> TestContext+parseForPlaceholders testContext label template value =+  let+    templateRegex =+      (RegexBase.makeRegex ("\\$[a-z0-9_]+" :: String)) :: Regex++    -- I'm sorry, this is ugly and complicated. To ease the pain, let's follow+    -- along with an example. Assuming we have:+    -- template = 00-0000000000000000$new_64_bit_trace_id-$new_span_id_2-01+    -- value = 00-0000000000000000b9e374754ca092b9-de54a2e7e1ceffc4-01+    -- Then we will get:++    -- placeholdersInString = [ '$new_64_bit_trace_id', '$new_span_id_2' ]+    placeholdersInStringMatches = RegexBase.matchAllText templateRegex template+    placeholdersInString =+       map+         (\match-> T.pack $ fst $ match ! 0)+         placeholdersInStringMatches++    -- Now escape "$" characters so they are used as literals in the regex:+    -- escapedPlaceholdersInString = [ '\\$new_64_bit_trace_id', '\\$new_span_id_2' ]+    escapedPlaceholdersInString =+      map (\tpl -> T.replace "$" "\\$" tpl) placeholdersInString++    -- Now we want to find all _fixed_ parts of the template string, that is,+    -- the parts between the placeholders:+    -- placeholderRegex = "^(.*)\\$new_64_bit_trace_id(.*)\\$new_span_id_2(.*)$"+    placeholderRegex =+      constructRegex "^(.*)" escapedPlaceholdersInString "(.*)" "(.*)$"++    fixedLiteralsMatchStructure =+      RegexBase.matchOnceText placeholderRegex template+    in+    case fixedLiteralsMatchStructure of++      Nothing ->+        addAssertion+          (assertFailure+              ("Failure: No fixed literals match for template " ++ template +++               " (" ++ label ++ ")."+              )+          )+          testContext++      Just (_, fixedLiteralsMatches, _) ->+        if null fixedLiteralsMatches+          then+            addAssertion+              (assertFailure+                  ("Failure: No placeholder match result " ++ template +++                   " (" ++ label ++ ")."+                  )+              )+              testContext+          else+            let+               -- fixedLiterals = [ '00-0000000000000000', '-', '-01' ]+               fixedLiterals = extractMatches fixedLiteralsMatches++               -- valuesRegex = '^00-0000000000000000(.*)-(.*)-01$'+               valuesRegex =+                 constructRegex "^" fixedLiterals "(.*)" "$"++               -- Finally, extract the values that the current value has for the+               -- placeholders.+               valuesMatchStructure =+                 RegexBase.matchOnceText valuesRegex value+               in+               case valuesMatchStructure of++                 Nothing ->+                   addAssertion+                     (assertFailure $+                       "Failure: Could not match the value " ++ value +++                       " against the template " ++ template +++                       " (" ++ label ++ ")."+                     )+                     testContext++                 Just (_, valuesMatches, _) ->+                   if null valuesMatches+                     then+                       addAssertion+                         (assertFailure $+                            "Failure: Could not match the value " ++ value +++                            " against the template " ++ template +++                            " (" ++ label ++ ")."+                         )+                         testContext+                     else+                       let+                         -- actualValues =+                         --   ['3124d02b3e5b1531', 'e16a9d4443b7e2d1']+                         actualValues = extractMatches valuesMatches+                       in+                       updatePlaceholdersAndCreateAssertions+                         testContext+                         label+                         placeholdersInString+                         actualValues+++updatePlaceholdersAndCreateAssertions ::+  TestContext+  -> String+  -> [Text]+  -> [Text]+  -> TestContext+updatePlaceholdersAndCreateAssertions+  testContext+  label+  placeholdersInString+  actualValues =+  foldr+    (\(idx, placeholder) currentTestContext ->+       let+         (_, currentValuesForPlaceholders) = currentTestContext+         existingValueM = lookup placeholder currentValuesForPlaceholders+         newValue = actualValues !! idx+       in+       case existingValueM of+         Just existingValue ->+           addAssertion+             ( assertEqual+                 ( T.unpack $ T.concat+                   [ "The placeholder "+                   , placeholder+                   , " had the value "+                   , existingValue+                   , " earlier but now it has the value "+                   , newValue+                   , ". The same placeholders needs to always have "+                   , "the same value throughout one single test case ("+                   , (T.pack label)+                   , ")."+                   ]+                 )+                 existingValue+                 newValue+             )+             currentTestContext++         Nothing ->+           addPlaceholderValue+             (placeholder, newValue)+             testContext+    )+    testContext+    (zip [0..] placeholdersInString)+++parseForPlaceholderJsonValue ::+  TestContext+  -> String+  -> String+  -> Maybe AesonTypes.Value+  -> TestContext+parseForPlaceholderJsonValue testContext label template value =+  case value of+    Just aesonValue ->+      case aesonValue of+        AesonTypes.String stringValue ->+          parseForPlaceholders+            testContext+            label+            template+            (T.unpack stringValue)+        _ ->+          addAssertion+            (assertFailure $+                "Failure: Expecte a string value but instead got " +++                show aesonValue ++ " when matching against the template " +++                template ++ " (" ++ label ++ ")."+            )+            testContext+    Nothing ->+      addAssertion+        (assertFailure $+            "Failure: A value was expected to be present in the HTTP " +++            "response but was not when matching against the template " +++            template ++ " (" ++ label ++ ")."++        )+        testContext+++constructRegex :: Text -> [Text] -> Text -> Text -> Regex+constructRegex start strings separator end =+  RegexBase.makeRegex+    (T.unpack $ T.concat+      [ start+      , T.intercalate separator strings+      , end+      ])+++extractMatches :: RegexBase.MatchText String -> [Text]+extractMatches matchArray =+  map+    (\submatch -> T.pack $ fst submatch)+    (tail $ Array.elems matchArray)+++assertEqualInMap ::+  String ->+  String ->+  Text ->+  HashMap Text Aeson.Value ->+  Assertion+assertEqualInMap label expected key jsonMap =+  assertEqual label+      (Just $ Aeson.String $ T.pack $ expected)+      (HashMap.lookup key jsonMap)+++assertNotInMap ::+  String ->+  Text ->+  HashMap Text Aeson.Value ->+  Assertion+assertNotInMap label key jsonMap =+  assertEqual label Nothing (HashMap.lookup key jsonMap)+

@@ -12,6 +12,7 @@   , withCustomServiceName   , withPidTranslation   , withStartupDelay+  , withW3cTraceCorrelationDisabled   ) where  @@ -30,11 +31,12 @@ -- |Describes options for running a test suite. data SuiteOptions =   SuiteOptions-    { usePidTranslation      :: Bool-    , startupDelay           :: Bool-    , simulateConnectionLoss :: Bool-    , customServiceName      :: Maybe String-    , appsUnderTest          :: [AppUnderTest]+    { usePidTranslation          :: Bool+    , startupDelay               :: Bool+    , simulateConnectionLoss     :: Bool+    , customServiceName          :: Maybe String+    , disableW3cTraceCorrelation :: Bool+    , appsUnderTest              :: [AppUnderTest]     }  @@ -50,11 +52,12 @@ defaultOptions :: SuiteOptions defaultOptions =   SuiteOptions-    { usePidTranslation      = False-    , startupDelay           = False-    , simulateConnectionLoss = False-    , appsUnderTest          = [testServer]-    , customServiceName      = Nothing+    { usePidTranslation           = False+    , startupDelay                = False+    , simulateConnectionLoss      = False+    , customServiceName           = Nothing+    , disableW3cTraceCorrelation  = False+    , appsUnderTest               = [testServer]     }  @@ -103,6 +106,11 @@ withCustomServiceName :: String -> SuiteOptions withCustomServiceName serviceName =   defaultOptions { customServiceName = Just serviceName }+++withW3cTraceCorrelationDisabled :: SuiteOptions+withW3cTraceCorrelationDisabled =+  defaultOptions { disableW3cTraceCorrelation = True }   data ConditionalSuite =

@@ -1,20 +1,22 @@ module Instana.SDK.IntegrationTest.TestSuites (allSuites) where  -import qualified Instana.SDK.IntegrationTest.BracketApi    as BracketApi-import qualified Instana.SDK.IntegrationTest.Connection    as Connection-import qualified Instana.SDK.IntegrationTest.HttpTracing   as HttpTracing-import qualified Instana.SDK.IntegrationTest.LowLevelApi   as LowLevelApi-import qualified Instana.SDK.IntegrationTest.Metrics       as Metrics-import qualified Instana.SDK.IntegrationTest.ServiceName   as ServiceName-import           Instana.SDK.IntegrationTest.Suite         (ConditionalSuite (..),-                                                            Suite (..))-import qualified Instana.SDK.IntegrationTest.Suite         as Suite-import qualified Instana.SDK.IntegrationTest.WaiMiddleware as WaiMiddleware+import qualified Data.Aeson                                 as Aeson+import qualified Instana.SDK.IntegrationTest.BracketApi     as BracketApi+import qualified Instana.SDK.IntegrationTest.Connection     as Connection+import qualified Instana.SDK.IntegrationTest.HttpTracing    as HttpTracing+import qualified Instana.SDK.IntegrationTest.LowLevelApi    as LowLevelApi+import qualified Instana.SDK.IntegrationTest.Metrics        as Metrics+import qualified Instana.SDK.IntegrationTest.ServiceName    as ServiceName+import qualified Instana.SDK.IntegrationTest.SpecCompliance as SpecCompliance+import           Instana.SDK.IntegrationTest.Suite          (ConditionalSuite (..),+                                                             Suite (..))+import qualified Instana.SDK.IntegrationTest.Suite          as Suite+import qualified Instana.SDK.IntegrationTest.WaiMiddleware  as WaiMiddleware  -allSuites :: [ConditionalSuite]-allSuites =+allSuites :: Aeson.Array -> [ConditionalSuite]+allSuites specificationComplianceTestCases =   [ testBracketApi   , testLowLevelApi   , testConnectionEstablishment@@ -24,6 +26,24 @@   , testServiceName   , testHttpTracing   , testWaiMiddleware+  , testSpecComplianceW3cOn+      specificationComplianceTestCases+      "Low Level API"+      "http/low/level/api"+  , testSpecComplianceW3cOff+      specificationComplianceTestCases+      "Low Level API"+      "http/low/level/api"+  , testSpecComplianceW3cOn+      specificationComplianceTestCases+      "Bracket API"+      "http/bracket/api"+  , testSpecComplianceW3cOff+      specificationComplianceTestCases+      "Bracket API"+      "http/bracket/api"+  , testSpecComplianceW3cOnWaiMiddleware specificationComplianceTestCases "api"+  , testSpecComplianceW3cOffWaiMiddleware specificationComplianceTestCases "api"   , testMetrics   ] @@ -33,12 +53,7 @@   Run $     Suite       { Suite.label = "Bracket API"-      , Suite.tests = (\pid ->-         [ BracketApi.shouldRecordSpans pid-         , BracketApi.shouldRecordNonRootEntry pid-         , BracketApi.shouldMergeTags pid-         , BracketApi.shouldSetServiceName pid-         ])+      , Suite.tests = BracketApi.allTests       , Suite.options = Suite.defaultOptions       } @@ -48,11 +63,7 @@   Run $     Suite       { Suite.label = "Low Level API"-      , Suite.tests = (\pid ->-         [ LowLevelApi.shouldRecordSpans pid-         , LowLevelApi.shouldRecordNonRootEntry pid-         , LowLevelApi.shouldMergeTags pid-         ])+      , Suite.tests = LowLevelApi.allTests       , Suite.options = Suite.defaultOptions       } @@ -110,9 +121,7 @@   Run $     Suite       { Suite.label = "INSTANA_SERVICE_NAME env var"-      , Suite.tests = (\pid ->-         [ ServiceName.shouldUseServiceNameEnvVar pid-         ])+      , Suite.tests = ServiceName.allTests       , Suite.options = Suite.withCustomServiceName "Custom Service Name"       } @@ -122,20 +131,7 @@   Run $     Suite       { Suite.label = "HTTP Tracing"-      , Suite.tests = (\pid -> [-          HttpTracing.shouldCreateRootEntryWithBracketApi pid-        , HttpTracing.shouldAddWebsiteMonitoringCorrelationWithBracketApi pid-        , HttpTracing.shouldIgnoreTraceIdParentIdIfWebsiteMonitoringCorrelationIsPresentWithBracketApi pid-        , HttpTracing.shouldCreateNonRootEntryWithBracketApi pid-        , HttpTracing.shouldSetSpanSyWithBracketApi pid-        , HttpTracing.shouldSuppressWithBracketApi-        , HttpTracing.shouldCreateRootEntryWithLowLevelApi pid-        , HttpTracing.shouldAddWebsiteMonitoringCorrelationWithLowLevelApi pid-        , HttpTracing.shouldIgnoreTraceIdParentIdIfWebsiteMonitoringCorrelationIsPresentWithLowLevelApi pid-        , HttpTracing.shouldCreateNonRootEntryWithLowLevelApi pid-        , HttpTracing.shouldSetSpanSyWithLowLevelApi pid-        , HttpTracing.shouldSuppressWithLowLevelApi-        ])+      , Suite.tests = HttpTracing.allTests       , Suite.options = Suite.defaultOptions {             Suite.appsUnderTest =               [ Suite.testServer@@ -145,19 +141,101 @@       }  +testSpecComplianceW3cOn :: Aeson.Array -> String -> String -> ConditionalSuite+testSpecComplianceW3cOn specificationComplianceTestCases apiLabel route =+  Run $+    Suite+      { Suite.label =+          "Specification Compliance (WC3 Trace Correlation On/" +++          apiLabel ++ ")"+      , Suite.tests =+          SpecCompliance.allTestsW3cCorrelationOn+            specificationComplianceTestCases+            Suite.testServer+            route+      , Suite.options = Suite.defaultOptions {+            Suite.appsUnderTest =+              [ Suite.testServer+              , Suite.downstreamTarget+              ]+          }+      }+++testSpecComplianceW3cOff :: Aeson.Array -> String -> String -> ConditionalSuite+testSpecComplianceW3cOff specificationComplianceTestCases apiLabel route =+  Run $+    Suite+      { Suite.label =+          "Specification Compliance (WC3 Trace Correlation Off/" +++          apiLabel ++ ")"+      , Suite.tests =+          SpecCompliance.allTestsW3cCorrelationOff+            specificationComplianceTestCases+            Suite.testServer+            route+      , Suite.options = Suite.withW3cTraceCorrelationDisabled {+            Suite.appsUnderTest =+              [ Suite.testServer+              , Suite.downstreamTarget+              ]+          }+      }++ testWaiMiddleware :: ConditionalSuite testWaiMiddleware =   Run $     Suite       { Suite.label = "WAI Middleware"-      , Suite.tests = (\pid -> [-          WaiMiddleware.shouldCreateRootEntry pid-        , WaiMiddleware.shouldCreateNonRootEntry pid-        , WaiMiddleware.shouldAddWebsiteMonitoringCorrelation pid-        , WaiMiddleware.shouldSuppress-        , WaiMiddleware.shouldCopeWithWrongNestingOfIoActions pid-        ])+      , Suite.tests = WaiMiddleware.allTests       , Suite.options = Suite.defaultOptions {+            Suite.appsUnderTest =+              [ Suite.testServerWithMiddleware+              , Suite.downstreamTarget+              ]+          }+      }+++testSpecComplianceW3cOnWaiMiddleware ::+  Aeson.Array+  -> String+  -> ConditionalSuite+testSpecComplianceW3cOnWaiMiddleware specificationComplianceTestCases route =+  Run $+    Suite+      { Suite.label =+          "Specification Compliance (WC3 Trace Correlation On/WAI Middleware)"+      , Suite.tests =+          SpecCompliance.allTestsW3cCorrelationOn+            specificationComplianceTestCases+            Suite.testServerWithMiddleware+            route+      , Suite.options = Suite.defaultOptions {+            Suite.appsUnderTest =+              [ Suite.testServerWithMiddleware+              , Suite.downstreamTarget+              ]+          }+      }+++testSpecComplianceW3cOffWaiMiddleware ::+  Aeson.Array+  -> String+  -> ConditionalSuite+testSpecComplianceW3cOffWaiMiddleware specificationComplianceTestCases route =+  Run $+    Suite+      { Suite.label =+          "Specification Compliance (WC3 Trace Correlation Off/WAI Middleware)"+      , Suite.tests =+          SpecCompliance.allTestsW3cCorrelationOff+            specificationComplianceTestCases+            Suite.testServerWithMiddleware+            route+      , Suite.options = Suite.withW3cTraceCorrelationDisabled {             Suite.appsUnderTest =               [ Suite.testServerWithMiddleware               , Suite.downstreamTarget

@@ -1,11 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}-module Instana.SDK.IntegrationTest.WaiMiddleware-  ( shouldCreateRootEntry-  , shouldCreateNonRootEntry-  , shouldAddWebsiteMonitoringCorrelation-  , shouldSuppress-  , shouldCopeWithWrongNestingOfIoActions-  ) where+module Instana.SDK.IntegrationTest.WaiMiddleware (allTests) where   import           Control.Concurrent                     (threadDelay)@@ -29,6 +23,16 @@ import           Test.HUnit  +allTests :: String -> [IO Test]+allTests pid =+  [ shouldCreateRootEntry pid+  , shouldCreateNonRootEntry pid+  , shouldAddWebsiteMonitoringCorrelation pid+  , shouldSuppress+  , shouldCopeWithWrongNestingOfIoActions pid+  ]++ shouldCreateRootEntry :: String -> IO Test shouldCreateRootEntry pid =   applyLabel "shouldCreateRootEntry" $@@ -142,8 +146,8 @@       [("X-INSTANA-L", "0")]   let     responseBody = LBSC8.unpack $ HTTP.responseBody response-  -- wait a second, then check that no spans have been recorded-  threadDelay $ 10 * 1000+  -- wait a few seconds, then check that no spans have been recorded+  threadDelay $ 5 * 1000 * 1000   spansResults <-     TestHelper.waitForRegisteredSpansMatching []   case spansResults of

@@ -1,15 +1,53 @@ module Main where  +import           Data.Aeson                             (Array)+import qualified Data.Aeson                             as Aeson+import qualified Data.ByteString.Lazy                   as LBS+import qualified System.Directory                       as Directory import           Test.HUnit  import qualified Instana.SDK.IntegrationTest.Logging    as Logging import qualified Instana.SDK.IntegrationTest.Runner     as TestRunner import qualified Instana.SDK.IntegrationTest.TestSuites as TestSuites+import qualified System.Exit                            as Exit   main :: IO Counts main = do   Logging.initLogging-  TestRunner.runSuites TestSuites.allSuites+  specificationComplianceTestCases <- parseSpecificationTestCasesJson+  case specificationComplianceTestCases of+    Just specTestCases ->+      TestRunner.runSuites $ TestSuites.allSuites specTestCases+    Nothing ->+      Exit.die $+        "ERROR: Could not parse specification test cases JSON file. " +++          "See above for details."+++specificationComplianceJsonFile :: FilePath+specificationComplianceJsonFile =+  "test/integration/Instana/SDK/IntegrationTest/" +++    "tracer_compliance_test_cases.json"+++parseSpecificationTestCasesJson :: IO (Maybe Array)+parseSpecificationTestCasesJson = do+  cwd <- Directory.getCurrentDirectory+  putStrLn $ "Running integration tests in directory " ++ show cwd+  putStrLn $+    "Parsing " ++ cwd ++ "/" ++ specificationComplianceJsonFile ++ "..."+  content <- LBS.readFile specificationComplianceJsonFile+  let+    decodedEither = Aeson.eitherDecode' content :: Either String Array+  case decodedEither of+    Left errorMessage -> do+      putStrLn $+        "Could not parse " ++ specificationComplianceJsonFile +++        " - is it valid JSON?"+      putStrLn errorMessage+      return Nothing+    Right result ->+      return $ Just result 

@@ -37,6 +37,28 @@     ]  +data InstanaAncestor = InstanaAncestor+  { traceId  :: Maybe String+  , parentId :: Maybe String+  } deriving (Eq, Generic, Show)+++instance FromJSON InstanaAncestor where+  parseJSON = Aeson.withObject "InstanaAncestor" $+    \obj ->+      InstanaAncestor+        <$> obj .: "t"+        <*> obj .: "p"+++instance ToJSON InstanaAncestor where+  toJSON :: InstanaAncestor -> Value+  toJSON instanaAncestor = Aeson.object+    [ "t" .= traceId instanaAncestor+    , "p" .= parentId instanaAncestor+    ]++ data Span =   Span     { t        :: String       -- traceId@@ -47,6 +69,9 @@     , d        :: Int          -- duration     , k        :: Int          -- kind     , ec       :: Int          -- errorCount+    , ia       :: Maybe InstanaAncestor -- instana ancestor+    , tp       :: Maybe Bool   -- traceparent has been used for trace continuity+    , lt       :: Maybe String -- long trace ID     , crtp     :: Maybe String -- correlation type     , crid     :: Maybe String -- correlation id     , sy       :: Maybe Bool   -- synthetic@@ -67,6 +92,9 @@         <*> decodedObject .:  "d"         <*> decodedObject .:  "k"         <*> decodedObject .:  "ec"+        <*> decodedObject .:? "ia"+        <*> decodedObject .:? "tp"+        <*> decodedObject .:? "lt"         <*> decodedObject .:  "crtp"         <*> decodedObject .:  "crid"         <*> decodedObject .:? "sy"@@ -84,6 +112,9 @@     , "d"    .= d sp     , "k"    .= k sp     , "ec"   .= ec sp+    , "ia"   .= ia sp+    , "tp"   .= tp sp+    , "lt"   .= lt sp     , "crtp" .= crtp sp     , "crid" .= crid sp     , "sy"   .= sy sp

@@ -11,14 +11,22 @@ allTests :: Test allTests =   TestList-    [ TestLabel "shouldParseDebug" shouldParseDebug-    , TestLabel "shouldParseInfo" shouldParseInfo-    , TestLabel "shouldParseNotice" shouldParseNotice-    , TestLabel "shouldParseWarning" shouldParseWarning-    , TestLabel "shouldParseError" shouldParseError-    , TestLabel "shouldParseCritical" shouldParseCritical-    , TestLabel "shouldParseAlert" shouldParseAlert-    , TestLabel "shouldParseEmergency" shouldParseEmergency+    [ TestLabel "shouldParseDebugUpperCase" shouldParseDebugUpperCase+    , TestLabel "shouldParseDebugLowerCase" shouldParseDebugLowerCase+    , TestLabel "shouldParseInfoUpperCase" shouldParseInfoUpperCase+    , TestLabel "shouldParseInfoLowerCase" shouldParseInfoLowerCase+    , TestLabel "shouldParseNoticeUpperCase" shouldParseNoticeUpperCase+    , TestLabel "shouldParseNoticeLowerCase" shouldParseNoticeLowerCase+    , TestLabel "shouldParseWarningUpperCase" shouldParseWarningUpperCase+    , TestLabel "shouldParseWarningLowerCase" shouldParseWarningLowerCase+    , TestLabel "shouldParseErrorUpperCase" shouldParseErrorUpperCase+    , TestLabel "shouldParseErrorLowerCase" shouldParseErrorLowerCase+    , TestLabel "shouldParseCriticalUpperCase" shouldParseCriticalUpperCase+    , TestLabel "shouldParseCriticalLowerCase" shouldParseCriticalLowerCase+    , TestLabel "shouldParseAlertUpperCase" shouldParseAlertUpperCase+    , TestLabel "shouldParseAlertLowerCase" shouldParseAlertLowerCase+    , TestLabel "shouldParseEmergencyUpperCase" shouldParseEmergencyUpperCase+    , TestLabel "shouldParseEmergencyLowerCase" shouldParseEmergencyLowerCase     , TestLabel "shouldParseEmpty" shouldParseEmpty     , TestLabel "shouldParseInvalid" shouldParseInvalid     , TestLabel "minOfTwoNothings" minOfTwoNothings@@ -29,66 +37,131 @@     ]  -shouldParseDebug :: Test-shouldParseDebug =+shouldParseDebugUpperCase :: Test+shouldParseDebugUpperCase =   let     parsed = Logging.parseLogLevel "DEBUG"   in     TestCase $ assertEqual "parsed level" (Just DEBUG) parsed  -shouldParseInfo :: Test-shouldParseInfo =+shouldParseDebugLowerCase :: Test+shouldParseDebugLowerCase =   let+    parsed = Logging.parseLogLevel "debug"+  in+    TestCase $ assertEqual "parsed level" (Just DEBUG) parsed++++shouldParseInfoUpperCase :: Test+shouldParseInfoUpperCase =+  let     parsed = Logging.parseLogLevel "INFO"   in     TestCase $ assertEqual "parsed level" (Just INFO) parsed  -shouldParseNotice :: Test-shouldParseNotice =+shouldParseInfoLowerCase :: Test+shouldParseInfoLowerCase =   let+    parsed = Logging.parseLogLevel "info"+  in+    TestCase $ assertEqual "parsed level" (Just INFO) parsed+++shouldParseNoticeUpperCase :: Test+shouldParseNoticeUpperCase =+  let     parsed = Logging.parseLogLevel "NOTICE"   in     TestCase $ assertEqual "parsed level" (Just NOTICE) parsed  -shouldParseWarning :: Test-shouldParseWarning =+shouldParseNoticeLowerCase :: Test+shouldParseNoticeLowerCase =   let+    parsed = Logging.parseLogLevel "notice"+  in+    TestCase $ assertEqual "parsed level" (Just NOTICE) parsed+++shouldParseWarningUpperCase :: Test+shouldParseWarningUpperCase =+  let     parsed = Logging.parseLogLevel "WARNING"   in     TestCase $ assertEqual "parsed level" (Just WARNING) parsed  -shouldParseError :: Test-shouldParseError =+shouldParseWarningLowerCase :: Test+shouldParseWarningLowerCase =   let+    parsed = Logging.parseLogLevel "warning"+  in+    TestCase $ assertEqual "parsed level" (Just WARNING) parsed+++shouldParseErrorUpperCase :: Test+shouldParseErrorUpperCase =+  let     parsed = Logging.parseLogLevel "ERROR"   in     TestCase $ assertEqual "parsed level" (Just ERROR) parsed  -shouldParseCritical :: Test-shouldParseCritical =+shouldParseErrorLowerCase :: Test+shouldParseErrorLowerCase =   let+    parsed = Logging.parseLogLevel "error"+  in+    TestCase $ assertEqual "parsed level" (Just ERROR) parsed+++shouldParseCriticalUpperCase :: Test+shouldParseCriticalUpperCase =+  let     parsed = Logging.parseLogLevel "CRITICAL"   in     TestCase $ assertEqual "parsed level" (Just CRITICAL) parsed  -shouldParseAlert :: Test-shouldParseAlert =+shouldParseCriticalLowerCase :: Test+shouldParseCriticalLowerCase =   let+    parsed = Logging.parseLogLevel "critical"+  in+    TestCase $ assertEqual "parsed level" (Just CRITICAL) parsed+++shouldParseAlertUpperCase :: Test+shouldParseAlertUpperCase =+  let     parsed = Logging.parseLogLevel "ALERT"   in     TestCase $ assertEqual "parsed level" (Just ALERT) parsed  -shouldParseEmergency :: Test-shouldParseEmergency =+shouldParseAlertLowerCase :: Test+shouldParseAlertLowerCase =   let+    parsed = Logging.parseLogLevel "alert"+  in+    TestCase $ assertEqual "parsed level" (Just ALERT) parsed+++shouldParseEmergencyUpperCase :: Test+shouldParseEmergencyUpperCase =+  let     parsed = Logging.parseLogLevel "EMERGENCY"+  in+    TestCase $ assertEqual "parsed level" (Just EMERGENCY) parsed+++shouldParseEmergencyLowerCase :: Test+shouldParseEmergencyLowerCase =+  let+    parsed = Logging.parseLogLevel "emergency"   in     TestCase $ assertEqual "parsed level" (Just EMERGENCY) parsed 

@@ -2,20 +2,24 @@ {-# LANGUAGE ScopedTypeVariables #-} module Instana.SDK.Internal.SpanStackTest (allTests) where -import           Data.Aeson                     (Value)-import qualified Data.Aeson                     as Aeson+import           Data.Aeson                           (Value)+import qualified Data.Aeson                           as Aeson import           Test.HUnit -import qualified Instana.SDK.Internal.Id        as Id-import           Instana.SDK.Internal.SpanStack (SpanStack)-import qualified Instana.SDK.Internal.SpanStack as SpanStack-import           Instana.SDK.Span.EntrySpan     (EntrySpan (RootEntrySpan))-import           Instana.SDK.Span.ExitSpan      (ExitSpan (ExitSpan))-import qualified Instana.SDK.Span.ExitSpan      as ExitSpan-import           Instana.SDK.Span.RootEntry     (RootEntry (RootEntry))-import qualified Instana.SDK.Span.RootEntry     as RootEntry-import           Instana.SDK.Span.Span          (Span (..), SpanKind (..))-import qualified Instana.SDK.Span.Span          as Span+import qualified Instana.SDK.Internal.Id              as Id+import           Instana.SDK.Internal.SpanStack       (SpanStack)+import qualified Instana.SDK.Internal.SpanStack       as SpanStack+import           Instana.SDK.Internal.W3CTraceContext (Flags (..),+                                                       TraceParent (..),+                                                       TraceState (..),+                                                       W3CTraceContext (..))+import           Instana.SDK.Span.EntrySpan           (EntrySpan (RootEntrySpan))+import           Instana.SDK.Span.ExitSpan            (ExitSpan (ExitSpan))+import qualified Instana.SDK.Span.ExitSpan            as ExitSpan+import           Instana.SDK.Span.RootEntry           (RootEntry (RootEntry))+import qualified Instana.SDK.Span.RootEntry           as RootEntry+import           Instana.SDK.Span.Span                (Span (..), SpanKind (..))+import qualified Instana.SDK.Span.Span                as Span   allTests :: Test@@ -369,7 +373,7 @@  suppressed :: SpanStack suppressed =-  SpanStack.suppress+  SpanStack.suppress dummyW3cTraceContext   entryOnly :: SpanStack@@ -399,20 +403,41 @@       , RootEntry.correlationType = Nothing       , RootEntry.correlationId   = Nothing       , RootEntry.spanData        = emptyValue+      , RootEntry.w3cTraceContext = Nothing       }   exitSpan :: ExitSpan exitSpan =   ExitSpan-    { ExitSpan.parentSpan   = entrySpan-    , ExitSpan.spanId      = Id.fromString "spanId"-    , ExitSpan.spanName    = "test.exit"-    , ExitSpan.timestamp   = 1514761201000-    , ExitSpan.errorCount  = 0-    , ExitSpan.serviceName = Nothing-    , ExitSpan.spanData    = emptyValue+    { ExitSpan.parentSpan      = entrySpan+    , ExitSpan.spanId          = Id.fromString "spanId"+    , ExitSpan.spanName        = "test.exit"+    , ExitSpan.timestamp       = 1514761201000+    , ExitSpan.errorCount      = 0+    , ExitSpan.serviceName     = Nothing+    , ExitSpan.spanData        = emptyValue+    , ExitSpan.w3cTraceContext = dummyW3cTraceContext     }+++dummyW3cTraceContext :: W3CTraceContext+dummyW3cTraceContext =+  W3CTraceContext+  { traceParent = TraceParent+    { version  = 0+    , traceId  = "trace-id"+    , parentId = "span-id"+    , flags    = Flags+      { sampled = False+      }+    }+  , traceState = TraceState+    { traceStateHead      = Nothing+    , instanaKeyValuePair = Nothing+    , traceStateTail      = Nothing+    }+  }   increaseEc :: Span -> Span

@@ -272,6 +272,7 @@         , RootEntry.correlationType = Nothing         , RootEntry.correlationId   = Nothing         , RootEntry.spanData        = initialData+        , RootEntry.w3cTraceContext = Nothing         }  

@@ -0,0 +1,721 @@+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Instana.SDK.Internal.W3CTraceContextTest (allTests) where+++import           Data.Text                            (Text)+import qualified Data.Text                            as T+import           Test.HUnit++import qualified Instana.SDK.Internal.Id              as Id+import           Instana.SDK.Internal.W3CTraceContext (Flags (..),+                                                       InstanaKeyValuePair (..),+                                                       TraceParent (..),+                                                       TraceState (..),+                                                       W3CTraceContext (..))+import qualified Instana.SDK.Internal.W3CTraceContext as W3CTraceContext+++allTests :: Test+allTests =+  TestList+    [ TestLabel+        "shouldDecodeEmptyTraceParentHeaderToNothing"+        shouldDecodeEmptyTraceParentHeaderToNothing+    , TestLabel+        "shouldDecodeWhitespaceTraceParentHeaderToNothing"+        shouldDecodeWhitespaceTraceParentHeaderToNothing+    , TestLabel+        "shouldDecodeMalformedTraceParentHeaderToNothing"+        shouldDecodeMalformedTraceParentHeaderToNothing+    , TestLabel+        "shouldDecodeWrongComponentLengthToNothing"+        shouldDecodeWrongComponentLengthToNothing+    , TestLabel+        "shouldDecodeInvalidVersionContentToNothing"+        shouldDecodeInvalidVersionContentToNothing+    , TestLabel+        "shouldDecodeInvalidVersionContentToNothing2"+        shouldDecodeInvalidVersionContentToNothing2+    , TestLabel+        "shouldDecodeInvalidTraceIdContentToNothing"+        shouldDecodeInvalidTraceIdContentToNothing+    , TestLabel+        "shouldDecodeInvalidTraceIdContentToNothing2"+        shouldDecodeInvalidTraceIdContentToNothing2+    , TestLabel+        "shouldDecodeInvalidParentIdContentToNothing"+        shouldDecodeInvalidParentIdContentToNothing+    , TestLabel+        "shouldDecodeInvalidParentIdContentToNothing2"+        shouldDecodeInvalidParentIdContentToNothing2+    , TestLabel+        "shouldDecodeInvalidFlagsContentToNothing"+        shouldDecodeInvalidFlagsContentToNothing+    , TestLabel+        "shouldDecodeValidTraceParent"+        shouldDecodeValidTraceParent+    , TestLabel+        "shouldDecodeUnsampledTraceParent"+        shouldDecodeUnsampledTraceParent+    , TestLabel+        "shouldDecodeKnownPartsFromHigherVersionTraceParent"+        shouldDecodeKnownPartsFromHigherVersionTraceParent+    , TestLabel+        "shouldDecodeAbsentTraceState"+        shouldDecodeAbsentTraceState+    , TestLabel+        "shouldDecodeEmptyTraceState"+        shouldDecodeEmptyTraceState+    , TestLabel+        "shouldDecodeWhitespaceTraceState"+        shouldDecodeWhitespaceTraceState+    , TestLabel+        "shouldDecodeTraceStateWithoutInstanaKeyValuePair"+        shouldDecodeTraceStateWithoutInstanaKeyValuePair+    , TestLabel+        "shouldDecodeTraceStateWithInstanaKeyValuePairAtBeginning"+        shouldDecodeTraceStateWithInstanaKeyValuePairAtBeginning+    , TestLabel+        "shouldDecodeTraceStateWithInstanaKeyValuePairInTheMiddle"+        shouldDecodeTraceStateWithInstanaKeyValuePairInTheMiddle+    , TestLabel+        "shouldDecodeTraceStateWithInstanaKeyValuePairAtTheEnd"+        shouldDecodeTraceStateWithInstanaKeyValuePairAtTheEnd+    , TestLabel+        "shouldDecodeTraceStateWithWhitespace"+        shouldDecodeTraceStateWithWhitespace+    , TestLabel+        "shouldDiscardMalformedInstanaKeyValuePair"+        shouldDiscardMalformedInstanaKeyValuePair+    , TestLabel+        "shouldInherit"+        shouldInherit+    , TestLabel+        "shouldInheritForSuppressed"+        shouldInheritForSuppressed+    , TestLabel+        "shouldCreateExitSpanContextFromIds"+        shouldCreateExitSpanContextFromIds+    , TestLabel+        "shouldCreateExitForSuppressed"+        shouldCreateExitForSuppressed+    , TestLabel+        "shouldEncodeToHeaders"+        shouldEncodeToHeaders+    , TestLabel+        "shouldPadShortIds"+        shouldPadShortIds+    , TestLabel+        "shouldLimitLongIds"+        shouldLimitLongIds+    , TestLabel+        "shouldDecodeInheritAndEncode"+        shouldDecodeInheritAndEncode+    ]+++shouldDecodeEmptyTraceParentHeaderToNothing :: Test+shouldDecodeEmptyTraceParentHeaderToNothing = testInvalidTraceParent ""+++shouldDecodeWhitespaceTraceParentHeaderToNothing :: Test+shouldDecodeWhitespaceTraceParentHeaderToNothing =+  testInvalidTraceParent "  \t \r\n "+++shouldDecodeMalformedTraceParentHeaderToNothing :: Test+shouldDecodeMalformedTraceParentHeaderToNothing = testInvalidTraceParent "foo"+++shouldDecodeWrongComponentLengthToNothing :: Test+shouldDecodeWrongComponentLengthToNothing =+  testInvalidTraceParent "beep-bop-beep-bop"+++shouldDecodeInvalidVersionContentToNothing :: Test+shouldDecodeInvalidVersionContentToNothing =+  testInvalidTraceParent+    "xx-1234567890abcdeffedcba0987654321-24680bdf13579abc-01"+++shouldDecodeInvalidVersionContentToNothing2 :: Test+shouldDecodeInvalidVersionContentToNothing2 =+  testInvalidTraceParent+    "ff-1234567890abcdeffedcba0987654321-24680bdf13579abc-01"+++shouldDecodeInvalidTraceIdContentToNothing :: Test+shouldDecodeInvalidTraceIdContentToNothing =+  testInvalidTraceParent+    "00-ABCD567890abcdeffedcba0987654321-24680bdf13579abc-01"+++shouldDecodeInvalidTraceIdContentToNothing2 :: Test+shouldDecodeInvalidTraceIdContentToNothing2 =+  testInvalidTraceParent+    "00-00000000000000000000000000000000-24680bdf13579abc-01"+++shouldDecodeInvalidParentIdContentToNothing :: Test+shouldDecodeInvalidParentIdContentToNothing =+  testInvalidTraceParent+    "00-1234567890abcdeffedcba0987654321-hijklmnopq579abc-01"+++shouldDecodeInvalidParentIdContentToNothing2 :: Test+shouldDecodeInvalidParentIdContentToNothing2 =+  testInvalidTraceParent+    "00-1234567890abcdeffedcba0987654321-0000000000000000-01"+++shouldDecodeInvalidFlagsContentToNothing :: Test+shouldDecodeInvalidFlagsContentToNothing =+  testInvalidTraceParent+    "00-1234567890abcdeffedcba0987654321-24680bdf13579abc-XX"+++shouldDecodeValidTraceParent :: Test+shouldDecodeValidTraceParent =+  let+    actual =+      W3CTraceContext.decode+        "00-1234567890abcdeffedcba0987654321-24680bdf13579abc-01"+        Nothing+    expected =+      sampledWithoutTraceState+        "1234567890abcdeffedcba0987654321"+        "24680bdf13579abc"+  in+  TestCase $ do+    assertEqual "W3C Trace Context" expected actual+++shouldDecodeUnsampledTraceParent :: Test+shouldDecodeUnsampledTraceParent =+  let+    actual =+      W3CTraceContext.decode+        "00-1234567890abcdeffedcba0987654321-24680bdf13579abc-00"+        Nothing+    expected =+      unsampledWithoutTraceState+        "1234567890abcdeffedcba0987654321"+        "24680bdf13579abc"+  in+  TestCase $ do+    assertEqual "W3C Trace Context" expected actual+++shouldDecodeKnownPartsFromHigherVersionTraceParent :: Test+shouldDecodeKnownPartsFromHigherVersionTraceParent =+  let+    actual =+      W3CTraceContext.decode+        "01-1234567890abcdeffedcba0987654321-24680bdf13579abc-01-beep-boop"+        Nothing+    expected =+      sampledWithoutTraceState+        "1234567890abcdeffedcba0987654321"+        "24680bdf13579abc"+  in+  TestCase $ do+    assertEqual "W3C Trace Context" expected actual+++testInvalidTraceParent :: String -> Test+testInvalidTraceParent tpContext =+  let+    w3cTraceContext = W3CTraceContext.decode tpContext Nothing+  in+  TestCase $ do+    assertEqual "W3C Trace Context"+      Nothing+      w3cTraceContext+++shouldDecodeAbsentTraceState :: Test+shouldDecodeAbsentTraceState =+  let+    actual = parseAndExtractTraceState Nothing+    expected = traceState $+      withTraceState defaultTraceParent Nothing Nothing Nothing+  in+  TestCase $ do+    assertEqual "Trace State" expected actual+++shouldDecodeEmptyTraceState :: Test+shouldDecodeEmptyTraceState =+  let+    actual = parseAndExtractTraceState (Just "")+    expected = traceState $+      withTraceState defaultTraceParent Nothing Nothing Nothing+  in+  TestCase $ do+    assertEqual "Trace State" expected actual+++shouldDecodeWhitespaceTraceState :: Test+shouldDecodeWhitespaceTraceState =+  let+    actual = parseAndExtractTraceState (Just "  \t  \r\n  ")+    expected = traceState $+      withTraceState defaultTraceParent Nothing Nothing Nothing+  in+  TestCase $ do+    assertEqual "Trace State" expected actual+++shouldDecodeTraceStateWithoutInstanaKeyValuePair :: Test+shouldDecodeTraceStateWithoutInstanaKeyValuePair =+  let+    actual =+      parseAndExtractTraceState $ Just+        "congo=ucfJifl5GOE,rojo=00f067aa0ba902b7"+    expected = traceState $ withTraceState+      defaultTraceParent+      (Just $ T.pack "congo=ucfJifl5GOE,rojo=00f067aa0ba902b7")+      Nothing+      Nothing+  in+  TestCase $ do+    assertEqual "Trace State" expected actual+++shouldDecodeTraceStateWithInstanaKeyValuePairAtBeginning :: Test+shouldDecodeTraceStateWithInstanaKeyValuePairAtBeginning =+  let+    actual =+      parseAndExtractTraceState $ Just+        "in=fa2375d711a4ca0f;02468acefdb97531,congo=ucfJifl5GOE,rojo=00f067aa0ba902b7"+    expected =+      traceState $+        withTraceState+          defaultTraceParent+          Nothing+          (Just $ InstanaKeyValuePair+             { instanaTraceId = "fa2375d711a4ca0f"+             , instanaParentId = "02468acefdb97531"+             }+          )+          (Just $ T.pack "congo=ucfJifl5GOE,rojo=00f067aa0ba902b7")+  in+  TestCase $ do+    assertEqual "Trace State" expected actual+++shouldDecodeTraceStateWithInstanaKeyValuePairInTheMiddle :: Test+shouldDecodeTraceStateWithInstanaKeyValuePairInTheMiddle =+  let+    actual =+      parseAndExtractTraceState $ Just+        "congo=ucfJifl5GOE,in=fa2375d711a4ca0f;02468acefdb97531,rojo=00f067aa0ba902b7"+    expected =+      traceState $+        withTraceState+          defaultTraceParent+          (Just $ T.pack "congo=ucfJifl5GOE")+          (Just $ InstanaKeyValuePair+             { instanaTraceId = "fa2375d711a4ca0f"+             , instanaParentId = "02468acefdb97531"+             }+          )+          (Just $ T.pack "rojo=00f067aa0ba902b7")+  in+  TestCase $ do+    assertEqual "Trace State" expected actual+++shouldDecodeTraceStateWithInstanaKeyValuePairAtTheEnd :: Test+shouldDecodeTraceStateWithInstanaKeyValuePairAtTheEnd =+  let+    actual =+      parseAndExtractTraceState $ Just+        "congo=ucfJifl5GOE,rojo=00f067aa0ba902b7,in=fa2375d711a4ca0f;02468acefdb97531"+    expected =+      traceState $+        withTraceState+          defaultTraceParent+          (Just $ T.pack "congo=ucfJifl5GOE,rojo=00f067aa0ba902b7")+          (Just $ InstanaKeyValuePair+             { instanaTraceId = "fa2375d711a4ca0f"+             , instanaParentId = "02468acefdb97531"+             }+          )+          Nothing+  in+  TestCase $ do+    assertEqual "Trace State" expected actual+++shouldDecodeTraceStateWithWhitespace :: Test+shouldDecodeTraceStateWithWhitespace =+  let+    actual =+      parseAndExtractTraceState $ Just+        "  congo = ucfJifl5GOE ,  in   =   fa2375d711a4ca0f  ; 02468acefdb97531   ,  rojo  =  00f067aa0ba902b7  "+    expected =+      traceState $+        withTraceState+          defaultTraceParent+          (Just $ T.pack "congo = ucfJifl5GOE")+          (Just $ InstanaKeyValuePair+             { instanaTraceId = "fa2375d711a4ca0f"+             , instanaParentId = "02468acefdb97531"+             }+          )+          (Just $ T.pack "rojo  =  00f067aa0ba902b7")+  in+  TestCase $ do+    assertEqual "Trace State" expected actual+++shouldDiscardMalformedInstanaKeyValuePair :: Test+shouldDiscardMalformedInstanaKeyValuePair =+  let+    actual =+      parseAndExtractTraceState $ Just+        "congo=ucfJifl5GOE,in=malformed,rojo=00f067aa0ba902b7"+    expected =+      traceState $+        withTraceState+          defaultTraceParent+          (Just $ T.pack "congo=ucfJifl5GOE")+          Nothing+          (Just $ T.pack "rojo=00f067aa0ba902b7")+  in+  TestCase $ do+    assertEqual "Trace State" expected actual+++shouldInherit :: Test+shouldInherit =+  let+    initialW3cCtx =+      withTraceState+        defaultTraceParent+        (Just $ T.pack "congo=ucfJifl5GOE")+        (Just $ InstanaKeyValuePair+           { instanaTraceId = "fa2375d711a4ca0f"+           , instanaParentId = "02468acefdb97531"+           }+        )+        (Just $ T.pack "rojo=00f067aa0ba902b7")++    actual =+      W3CTraceContext.inheritFrom+        initialW3cCtx+        "5a6b7c8d9ef13402"+        "234123567890abcd"++    expected =+      W3CTraceContext+        { traceParent = TraceParent+          { version  = 0+          , traceId  = "1234567890abcdeffedcba0987654321"+          , parentId = "234123567890abcd"+          , flags    = Flags+            { sampled = True+            }+          }+        , traceState = TraceState+         { traceStateHead = Nothing+          , instanaKeyValuePair = Just InstanaKeyValuePair+            { instanaTraceId = "5a6b7c8d9ef13402"+            , instanaParentId = "234123567890abcd"+            }+          , traceStateTail = Just "congo=ucfJifl5GOE,rojo=00f067aa0ba902b7"+          }+        }+  in+  TestCase $ do+    assertEqual "W3C Trace Context" expected actual+++shouldInheritForSuppressed :: Test+shouldInheritForSuppressed =+  let+    initialW3cCtx =+      withTraceState+        defaultTraceParent+        (Just $ T.pack "congo=ucfJifl5GOE")+        (Just $ InstanaKeyValuePair+           { instanaTraceId = "fa2375d711a4ca0f"+           , instanaParentId = "02468acefdb97531"+           }+        )+        (Just $ T.pack "rojo=00f067aa0ba902b7")++    actual =+      W3CTraceContext.inheritFromForSuppressed+        initialW3cCtx+        "234123567890abcd"++    expected =+      W3CTraceContext+        { traceParent = TraceParent+          { version  = 0+          , traceId  = "1234567890abcdeffedcba0987654321"+          , parentId = "234123567890abcd"+          , flags    = Flags+            { sampled = False+            }+          }+        , traceState = TraceState+          { traceStateHead = Just "congo=ucfJifl5GOE"+          , instanaKeyValuePair = Nothing+          , traceStateTail = Just "rojo=00f067aa0ba902b7"+          }+        }+  in+  TestCase $ do+    assertEqual "W3C Trace Context" expected actual+++shouldCreateExitSpanContextFromIds :: Test+shouldCreateExitSpanContextFromIds =+  let+    actual =+      W3CTraceContext.exitSpanContextFromIds+        "274193a6f8c03721"+        "345fcb9140c8a6b9"++    expected =+      W3CTraceContext+        { traceParent = TraceParent+          { version  = 0+          , traceId  = "274193a6f8c03721"+          , parentId = "345fcb9140c8a6b9"+          , flags    = Flags+            { sampled = True+            }+          }+        , traceState = TraceState+          { traceStateHead = Nothing+          , instanaKeyValuePair = Just InstanaKeyValuePair+            { instanaTraceId  = "274193a6f8c03721"+            , instanaParentId = "345fcb9140c8a6b9"+            }+          , traceStateTail = Nothing+          }+        }+  in+  TestCase $ do+    assertEqual "W3C Trace Context" expected actual+++shouldCreateExitForSuppressed :: Test+shouldCreateExitForSuppressed =+  let+    actual =+      W3CTraceContext.createExitContextForSuppressed+        "274193a6f8c03721"+        "345fcb9140c8a6b9"++    expected =+      W3CTraceContext+        { traceParent = TraceParent+          { version  = 0+          , traceId  = "274193a6f8c03721"+          , parentId = "345fcb9140c8a6b9"+          , flags    = Flags+            { sampled = False+            }+          }+        , traceState = TraceState+          { traceStateHead = Nothing+          , instanaKeyValuePair = Nothing+          , traceStateTail = Nothing+          }+        }+  in+  TestCase $ do+    assertEqual "W3C Trace Context" expected actual+++shouldEncodeToHeaders :: Test+shouldEncodeToHeaders =+  let+    actual =+      W3CTraceContext.toHeaders $+        withTraceState+          defaultTraceParent+          (Just $ T.pack "congo=ucfJifl5GOE")+          (Just $ InstanaKeyValuePair+             { instanaTraceId = "fa2375d711a4ca0f"+             , instanaParentId = "02468acefdb97531"+             }+          )+          (Just $ T.pack "rojo=00f067aa0ba902b7")++    expected =+      [ ( "traceparent"+        , "00-1234567890abcdeffedcba0987654321-24680bdf13579abc-01"+        )+      , ( "tracestate"+        , "in=fa2375d711a4ca0f;02468acefdb97531,congo=ucfJifl5GOE,rojo=00f067aa0ba902b7"+        )+      ]+  in+  TestCase $ do+    assertEqual "W3C Trace Context Headers" expected actual+++shouldPadShortIds :: Test+shouldPadShortIds =+  let+    Just w3cCtx =+      (sampledWithoutTraceState+        "1234"+        "5678")+    actual =+      W3CTraceContext.toHeaders $+        withTraceState+          (traceParent w3cCtx)+          (Just $ T.pack "congo=ucfJifl5GOE")+          (Just $ InstanaKeyValuePair+             { instanaTraceId = "9abc"+             , instanaParentId = "defg"+             }+          )+          (Just $ T.pack "rojo=00f067aa0ba902b7")++    expected =+      [ ( "traceparent"+        , "00-00000000000000000000000000001234-0000000000005678-01"+        )+      , ( "tracestate"+        , "in=0000000000009abc;000000000000defg,congo=ucfJifl5GOE,rojo=00f067aa0ba902b7"+        )+      ]+  in+  TestCase $ do+    assertEqual "W3C Trace Context Headers" expected actual+++shouldLimitLongIds :: Test+shouldLimitLongIds =+  let+    Just w3cCtx =+      (sampledWithoutTraceState+        "fedcba9876543210abcdef0123456789fffff"+        "112233445566778899")+    actual =+      W3CTraceContext.toHeaders w3cCtx++    expected =+      [ ( "traceparent"+        , "00-a9876543210abcdef0123456789fffff-2233445566778899-01"+        )+      ]+  in+  TestCase $ do+    assertEqual "W3C Trace Context Headers" expected actual+++shouldDecodeInheritAndEncode :: Test+shouldDecodeInheritAndEncode =+  let+    Just decoded =+      W3CTraceContext.decode+        "00-1234567890abcdeffedcba0987654321-24680bdf13579abc-01"+        (Just "congo=ucfJifl5GOE,in=fa2375d711a4ca0f;02468acefdb97531,rojo=00f067aa0ba902b7")++    childCtx =+      W3CTraceContext.inheritFrom+        decoded+        "5a6b7c8d9ef13402"+        "234123567890abcd"++    actual =+      W3CTraceContext.toHeaders childCtx++    expected =+      [ ( "traceparent"+        , "00-1234567890abcdeffedcba0987654321-234123567890abcd-01"+        )+      , ( "tracestate"+        , "in=5a6b7c8d9ef13402;234123567890abcd,congo=ucfJifl5GOE,rojo=00f067aa0ba902b7"+        )+      ]+  in+  TestCase $ do+    assertEqual "W3C Trace Context Headers" expected actual+++sampledWithoutTraceState :: String -> String -> Maybe W3CTraceContext+sampledWithoutTraceState tId pId =+  Just $+    W3CTraceContext+      { traceParent = TraceParent+        { version  = 0+        , traceId  = Id.fromString tId+        , parentId = Id.fromString pId+        , flags    = Flags+          { sampled = True+          }+        }+      , traceState = TraceState+        { traceStateHead = Nothing+        , instanaKeyValuePair = Nothing+        , traceStateTail = Nothing+        }+      }+++unsampledWithoutTraceState :: String -> String -> Maybe W3CTraceContext+unsampledWithoutTraceState tId pId =+  unsampled $ sampledWithoutTraceState tId pId+++unsampled :: Maybe W3CTraceContext -> Maybe W3CTraceContext+unsampled mW3cCtx =+  let+    Just w3cCtx = mW3cCtx+    tp = traceParent w3cCtx+    fl = flags tp+    unsampledTp = tp { flags = fl { sampled = False } }+  in+  Just $ w3cCtx { traceParent = unsampledTp }+++parseAndExtractTraceState :: Maybe String -> TraceState+parseAndExtractTraceState traceStateHeader =+  let+    Just w3cCtx =+        W3CTraceContext.decode+          "00-1234567890abcdeffedcba0987654321-24680bdf13579abc-01"+          traceStateHeader+  in+  traceState $ w3cCtx+++withTraceState ::+  TraceParent+  -> Maybe Text+  -> Maybe InstanaKeyValuePair+  -> Maybe Text+  -> W3CTraceContext+withTraceState tp tsHead inKvPair tsTail =+  W3CTraceContext+    { traceParent = tp+    , traceState = TraceState+      { traceStateHead = tsHead+      , instanaKeyValuePair = inKvPair+      , traceStateTail = tsTail+      }+    }+++defaultTraceParent :: TraceParent+defaultTraceParent =+  TraceParent+    { version  = 0+    , traceId  = "1234567890abcdeffedcba0987654321"+    , parentId = "24680bdf13579abc"+    , flags    = Flags+      { sampled = True+      }+    }+

@@ -3,6 +3,8 @@ module Instana.SDK.TracingHeadersTest (allTests) where  +import qualified Data.CaseInsensitive       as CI+import qualified Network.Wai                as Wai import           Test.HUnit  import           Instana.SDK.TracingHeaders (TracingLevel (..))@@ -12,7 +14,12 @@ allTests :: Test allTests =   TestList-    [ TestLabel+    [ TestLabel "shouldReadHeaders" shouldReadHeaders+    , TestLabel+        "shouldReadHeaderNamesCaseInsensitive"+        shouldReadHeaderNamesCaseInsensitive+    , TestLabel "shouldReadDefaultValues" shouldReadDefaultValues+    , TestLabel         "shouldParseNonExistingXInstanaL"         shouldParseNonExistingXInstanaL     , TestLabel "shouldParseXInstanaL1" shouldParseXInstanaL1@@ -31,6 +38,128 @@     ]  +shouldReadDefaultValues :: Test+shouldReadDefaultValues =+  let+    tracingHeaders =+      TracingHeaders.readHttpTracingHeaders Wai.defaultRequest+  in+  TestCase $ do+    assertEqual "trace ID"+      Nothing+      (TracingHeaders.traceId tracingHeaders)+    assertEqual "span ID"+      Nothing+      (TracingHeaders.spanId tracingHeaders)+    assertEqual "level" Trace (TracingHeaders.level tracingHeaders)+    assertEqual "correlationType"+      Nothing+      (TracingHeaders.correlationType tracingHeaders)+    assertEqual "correlationId"+      Nothing+      (TracingHeaders.correlationId tracingHeaders)+    assertEqual "synthetic"+      False+      (TracingHeaders.synthetic tracingHeaders)+    assertEqual "traceparent"+      Nothing+      (TracingHeaders.traceparent tracingHeaders)+    assertEqual "tracestate"+      Nothing+      (TracingHeaders.tracestate tracingHeaders)+++shouldReadHeaders :: Test+shouldReadHeaders =+  let+    tracingHeaders =+      TracingHeaders.readHttpTracingHeaders $+        Wai.defaultRequest+          { Wai.requestHeaders =+              [ (CI.mk "X-INSTANA-T", "1234567890abcdef")+              , (CI.mk "X-INSTANA-S", "abcdef1234567890")+              , (CI.mk "X-INSTANA-L", "1")+              , (CI.mk "X-INSTANA-SYNTHETIC", "1")+              , (CI.mk "traceparent",+                  "00-00000000000000001234567890abcdef-abcdef1234567890-01"+                )+              , (CI.mk "tracestate",+                  "foo=bar,in=1234567890abcdef;abcdef1234567890,beep=bop"+                )+              ]+          }+  in+  TestCase $ do+    assertEqual "trace ID"+      (Just "1234567890abcdef")+      (TracingHeaders.traceId tracingHeaders)+    assertEqual "span ID"+      (Just "abcdef1234567890")+      (TracingHeaders.spanId tracingHeaders)+    assertEqual "level" Trace (TracingHeaders.level tracingHeaders)+    assertEqual "correlationType"+      Nothing+      (TracingHeaders.correlationType tracingHeaders)+    assertEqual "correlationId"+      Nothing+      (TracingHeaders.correlationId tracingHeaders)+    assertEqual "synthetic"+      True+      (TracingHeaders.synthetic tracingHeaders)+    assertEqual "traceparent"+      (Just "00-00000000000000001234567890abcdef-abcdef1234567890-01")+      (TracingHeaders.traceparent tracingHeaders)+    assertEqual "tracestate"+      (Just "foo=bar,in=1234567890abcdef;abcdef1234567890,beep=bop")+      (TracingHeaders.tracestate tracingHeaders)+++shouldReadHeaderNamesCaseInsensitive :: Test+shouldReadHeaderNamesCaseInsensitive =+  let+    tracingHeaders =+      TracingHeaders.readHttpTracingHeaders $+        Wai.defaultRequest+          { Wai.requestHeaders =+              [ (CI.mk "x-inSTanA-t", "1234567890abcdef")+              , (CI.mk "X-Instana-S", "abcdef1234567890")+              , (CI.mk "x-instana-synthetic", "1")+              , (CI.mk "TRACEPARENT",+                  "00-00000000000000001234567890abcdef-abcdef1234567890-01"+                )+              , (CI.mk "TRACESTATE",+                  "foo=bar,in=1234567890abcdef;abcdef1234567890,beep=bop"+                )+              ]+          }+  in+  TestCase $ do+    assertEqual "trace ID"+      (Just "1234567890abcdef")+      (TracingHeaders.traceId tracingHeaders)+    assertEqual "span ID"+      (Just "abcdef1234567890")+      (TracingHeaders.spanId tracingHeaders)+    assertEqual "level" Trace (TracingHeaders.level tracingHeaders)+    assertEqual "correlationType"+      Nothing+      (TracingHeaders.correlationType tracingHeaders)+    assertEqual "correlationId"+      Nothing+      (TracingHeaders.correlationId tracingHeaders)+    assertEqual "synthetic"+      True+      (TracingHeaders.synthetic tracingHeaders)+    assertEqual "traceparent"+      (Just "00-00000000000000001234567890abcdef-abcdef1234567890-01")+      (TracingHeaders.traceparent tracingHeaders)+    assertEqual "tracestate"+      (Just "foo=bar,in=1234567890abcdef;abcdef1234567890,beep=bop")+      (TracingHeaders.tracestate tracingHeaders)++++ shouldParseNonExistingXInstanaL :: Test shouldParseNonExistingXInstanaL =   let@@ -38,7 +167,7 @@       TracingHeaders.parseXInstanaL Nothing   in   TestCase $ do-    assertEqual "level" level Trace+    assertEqual "level" Trace level     assertEqual "correlation type" Nothing correlationType     assertEqual "correlation ID" Nothing correlationId @@ -50,7 +179,7 @@       TracingHeaders.parseXInstanaL $ Just "1"   in   TestCase $ do-    assertEqual "level" level Trace+    assertEqual "level" Trace level     assertEqual "correlation type" Nothing correlationType     assertEqual "correlation ID" Nothing correlationId @@ -62,7 +191,7 @@       TracingHeaders.parseXInstanaL $ Just "  1  "   in   TestCase $ do-    assertEqual "level" level Trace+    assertEqual "level" Trace level     assertEqual "correlation type" Nothing correlationType     assertEqual "correlation ID" Nothing correlationId @@ -110,7 +239,7 @@       TracingHeaders.parseXInstanaL $ Just "1,correlationType=web;correlationId=1234567890abcdef"   in   TestCase $ do-    assertEqual "level" level Trace+    assertEqual "level" Trace level     assertEqual "correlation type" (Just "web") correlationType     assertEqual "correlation ID" (Just "1234567890abcdef") correlationId @@ -122,7 +251,7 @@       TracingHeaders.parseXInstanaL $ Just "  1 ,  correlationType = web  ;  correlationId =  1234567890abcdef"   in   TestCase $ do-    assertEqual "level" level Trace+    assertEqual "level" Trace level     assertEqual "correlation type" (Just "web") correlationType     assertEqual "correlation ID" (Just "1234567890abcdef") correlationId 

@@ -11,6 +11,7 @@ import qualified Instana.SDK.Internal.ServerTimingTest              as ServerTimingTest import qualified Instana.SDK.Internal.SpanStackTest                 as SpanStackTest import qualified Instana.SDK.Internal.SpanTest                      as SpanTest+import qualified Instana.SDK.Internal.W3CTraceContextTest           as W3CTraceContextTest import qualified Instana.SDK.TracingHeadersTest                     as TracingHeadersTest  import           Test.HUnit@@ -35,5 +36,6 @@     , SpanStackTest.allTests     , SpanTest.allTests     , TracingHeadersTest.allTests+    , W3CTraceContextTest.allTests     ]