diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -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 . + * 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 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 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. + diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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` diff --git a/instana-haskell-trace-sdk.cabal b/instana-haskell-trace-sdk.cabal --- a/instana-haskell-trace-sdk.cabal +++ b/instana-haskell-trace-sdk.cabal @@ -1,5 +1,5 @@ name: instana-haskell-trace-sdk -version: 0.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 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 diff --git a/src/Instana/SDK/Config.hs b/src/Instana/SDK/Config.hs --- a/src/Instana/SDK/Config.hs +++ b/src/Instana/SDK/Config.hs @@ -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 } diff --git a/src/Instana/SDK/Internal/Config.hs b/src/Instana/SDK/Internal/Config.hs --- a/src/Instana/SDK/Internal/Config.hs +++ b/src/Instana/SDK/Internal/Config.hs @@ -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 + diff --git a/src/Instana/SDK/Internal/Id.hs b/src/Instana/SDK/Internal/Id.hs --- a/src/Instana/SDK/Internal/Id.hs +++ b/src/Instana/SDK/Internal/Id.hs @@ -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. diff --git a/src/Instana/SDK/Internal/Logging.hs b/src/Instana/SDK/Internal/Logging.hs --- a/src/Instana/SDK/Internal/Logging.hs +++ b/src/Instana/SDK/Internal/Logging.hs @@ -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 diff --git a/src/Instana/SDK/Internal/SpanStack.hs b/src/Instana/SDK/Internal/SpanStack.hs --- a/src/Instana/SDK/Internal/SpanStack.hs +++ b/src/Instana/SDK/Internal/SpanStack.hs @@ -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) = diff --git a/src/Instana/SDK/Internal/Util.hs b/src/Instana/SDK/Internal/Util.hs --- a/src/Instana/SDK/Internal/Util.hs +++ b/src/Instana/SDK/Internal/Util.hs @@ -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 + diff --git a/src/Instana/SDK/Internal/W3CTraceContext.hs b/src/Instana/SDK/Internal/W3CTraceContext.hs new file mode 100644 --- /dev/null +++ b/src/Instana/SDK/Internal/W3CTraceContext.hs @@ -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 + diff --git a/src/Instana/SDK/Internal/WireSpan.hs b/src/Instana/SDK/Internal/WireSpan.hs --- a/src/Instana/SDK/Internal/WireSpan.hs +++ b/src/Instana/SDK/Internal/WireSpan.hs @@ -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_ ] diff --git a/src/Instana/SDK/Internal/Worker.hs b/src/Instana/SDK/Internal/Worker.hs --- a/src/Instana/SDK/Internal/Worker.hs +++ b/src/Instana/SDK/Internal/Worker.hs @@ -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 } diff --git a/src/Instana/SDK/SDK.hs b/src/Instana/SDK/SDK.hs --- a/src/Instana/SDK/SDK.hs +++ b/src/Instana/SDK/SDK.hs @@ -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. diff --git a/src/Instana/SDK/Span/EntrySpan.hs b/src/Instana/SDK/Span/EntrySpan.hs --- a/src/Instana/SDK/Span/EntrySpan.hs +++ b/src/Instana/SDK/Span/EntrySpan.hs @@ -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 diff --git a/src/Instana/SDK/Span/ExitSpan.hs b/src/Instana/SDK/Span/ExitSpan.hs --- a/src/Instana/SDK/Span/ExitSpan.hs +++ b/src/Instana/SDK/Span/ExitSpan.hs @@ -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. diff --git a/src/Instana/SDK/Span/NonRootEntry.hs b/src/Instana/SDK/Span/NonRootEntry.hs --- a/src/Instana/SDK/Span/NonRootEntry.hs +++ b/src/Instana/SDK/Span/NonRootEntry.hs @@ -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. diff --git a/src/Instana/SDK/Span/RootEntry.hs b/src/Instana/SDK/Span/RootEntry.hs --- a/src/Instana/SDK/Span/RootEntry.hs +++ b/src/Instana/SDK/Span/RootEntry.hs @@ -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. diff --git a/src/Instana/SDK/Span/Span.hs b/src/Instana/SDK/Span/Span.hs --- a/src/Instana/SDK/Span/Span.hs +++ b/src/Instana/SDK/Span/Span.hs @@ -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_ diff --git a/src/Instana/SDK/TracingHeaders.hs b/src/Instana/SDK/TracingHeaders.hs --- a/src/Instana/SDK/TracingHeaders.hs +++ b/src/Instana/SDK/TracingHeaders.hs @@ -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 + } diff --git a/test/integration/Instana/SDK/IntegrationTest/BracketApi.hs b/test/integration/Instana/SDK/IntegrationTest/BracketApi.hs --- a/test/integration/Instana/SDK/IntegrationTest/BracketApi.hs +++ b/test/integration/Instana/SDK/IntegrationTest/BracketApi.hs @@ -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 diff --git a/test/integration/Instana/SDK/IntegrationTest/HUnitExtra.hs b/test/integration/Instana/SDK/IntegrationTest/HUnitExtra.hs --- a/test/integration/Instana/SDK/IntegrationTest/HUnitExtra.hs +++ b/test/integration/Instana/SDK/IntegrationTest/HUnitExtra.hs @@ -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 + ) diff --git a/test/integration/Instana/SDK/IntegrationTest/HttpTracing.hs b/test/integration/Instana/SDK/IntegrationTest/HttpTracing.hs --- a/test/integration/Instana/SDK/IntegrationTest/HttpTracing.hs +++ b/test/integration/Instana/SDK/IntegrationTest/HttpTracing.hs @@ -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 diff --git a/test/integration/Instana/SDK/IntegrationTest/LowLevelApi.hs b/test/integration/Instana/SDK/IntegrationTest/LowLevelApi.hs --- a/test/integration/Instana/SDK/IntegrationTest/LowLevelApi.hs +++ b/test/integration/Instana/SDK/IntegrationTest/LowLevelApi.hs @@ -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 diff --git a/test/integration/Instana/SDK/IntegrationTest/Metrics.hs b/test/integration/Instana/SDK/IntegrationTest/Metrics.hs --- a/test/integration/Instana/SDK/IntegrationTest/Metrics.hs +++ b/test/integration/Instana/SDK/IntegrationTest/Metrics.hs @@ -51,7 +51,7 @@ (EntityDataRequest.arguments entityData) , assertLabelIs "sensorVersion" - "0.6.2.0" + "0.7.0.0" (EntityDataRequest.sensorVersion entityData) , assertCounterSatisfies "startTime" diff --git a/test/integration/Instana/SDK/IntegrationTest/Runner.hs b/test/integration/Instana/SDK/IntegrationTest/Runner.hs --- a/test/integration/Instana/SDK/IntegrationTest/Runner.hs +++ b/test/integration/Instana/SDK/IntegrationTest/Runner.hs @@ -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 diff --git a/test/integration/Instana/SDK/IntegrationTest/ServiceName.hs b/test/integration/Instana/SDK/IntegrationTest/ServiceName.hs --- a/test/integration/Instana/SDK/IntegrationTest/ServiceName.hs +++ b/test/integration/Instana/SDK/IntegrationTest/ServiceName.hs @@ -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 diff --git a/test/integration/Instana/SDK/IntegrationTest/SpecCompliance.hs b/test/integration/Instana/SDK/IntegrationTest/SpecCompliance.hs new file mode 100644 --- /dev/null +++ b/test/integration/Instana/SDK/IntegrationTest/SpecCompliance.hs @@ -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¶meters=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¶meters=1" :: String) + , "status" .= (200 :: Int) + ] + ) + ] + ) + (TraceRequest.spanData entrySpan) + , assertBool "exit timestamp" $ TraceRequest.ts exitSpan > 0 + , assertBool "exit duration" $ TraceRequest.d exitSpan > 0 + , assertEqual "exit kind" 2 (TraceRequest.k exitSpan) + , assertEqual "exit error count" 0 (TraceRequest.ec exitSpan) + , assertEqual "exit from" from $ TraceRequest.f exitSpan + , assertEqual "exit data" + ( Aeson.object + [ "http" .= (Aeson.object + [ "method" .= ("GET" :: String) + , "url" .= ("http://127.0.0.1:1208/echo" :: String) + , "params" .= ("some=query¶meters=2" :: 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) + diff --git a/test/integration/Instana/SDK/IntegrationTest/Suite.hs b/test/integration/Instana/SDK/IntegrationTest/Suite.hs --- a/test/integration/Instana/SDK/IntegrationTest/Suite.hs +++ b/test/integration/Instana/SDK/IntegrationTest/Suite.hs @@ -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 = diff --git a/test/integration/Instana/SDK/IntegrationTest/TestSuites.hs b/test/integration/Instana/SDK/IntegrationTest/TestSuites.hs --- a/test/integration/Instana/SDK/IntegrationTest/TestSuites.hs +++ b/test/integration/Instana/SDK/IntegrationTest/TestSuites.hs @@ -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 diff --git a/test/integration/Instana/SDK/IntegrationTest/WaiMiddleware.hs b/test/integration/Instana/SDK/IntegrationTest/WaiMiddleware.hs --- a/test/integration/Instana/SDK/IntegrationTest/WaiMiddleware.hs +++ b/test/integration/Instana/SDK/IntegrationTest/WaiMiddleware.hs @@ -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 diff --git a/test/integration/Main.hs b/test/integration/Main.hs --- a/test/integration/Main.hs +++ b/test/integration/Main.hs @@ -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 diff --git a/test/shared/Instana/SDK/AgentStub/TraceRequest.hs b/test/shared/Instana/SDK/AgentStub/TraceRequest.hs --- a/test/shared/Instana/SDK/AgentStub/TraceRequest.hs +++ b/test/shared/Instana/SDK/AgentStub/TraceRequest.hs @@ -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 diff --git a/test/unit/Instana/SDK/Internal/LoggingTest.hs b/test/unit/Instana/SDK/Internal/LoggingTest.hs --- a/test/unit/Instana/SDK/Internal/LoggingTest.hs +++ b/test/unit/Instana/SDK/Internal/LoggingTest.hs @@ -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 diff --git a/test/unit/Instana/SDK/Internal/SpanStackTest.hs b/test/unit/Instana/SDK/Internal/SpanStackTest.hs --- a/test/unit/Instana/SDK/Internal/SpanStackTest.hs +++ b/test/unit/Instana/SDK/Internal/SpanStackTest.hs @@ -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 diff --git a/test/unit/Instana/SDK/Internal/SpanTest.hs b/test/unit/Instana/SDK/Internal/SpanTest.hs --- a/test/unit/Instana/SDK/Internal/SpanTest.hs +++ b/test/unit/Instana/SDK/Internal/SpanTest.hs @@ -272,6 +272,7 @@ , RootEntry.correlationType = Nothing , RootEntry.correlationId = Nothing , RootEntry.spanData = initialData + , RootEntry.w3cTraceContext = Nothing } diff --git a/test/unit/Instana/SDK/Internal/W3CTraceContextTest.hs b/test/unit/Instana/SDK/Internal/W3CTraceContextTest.hs new file mode 100644 --- /dev/null +++ b/test/unit/Instana/SDK/Internal/W3CTraceContextTest.hs @@ -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 + } + } + diff --git a/test/unit/Instana/SDK/TracingHeadersTest.hs b/test/unit/Instana/SDK/TracingHeadersTest.hs --- a/test/unit/Instana/SDK/TracingHeadersTest.hs +++ b/test/unit/Instana/SDK/TracingHeadersTest.hs @@ -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 diff --git a/test/unit/Main.hs b/test/unit/Main.hs --- a/test/unit/Main.hs +++ b/test/unit/Main.hs @@ -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 ]