diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md new file mode 100644 --- /dev/null +++ b/CONTRIBUTING.md @@ -0,0 +1,58 @@ +Contributing to the Instana Haskell Trace SDK +============================================= + +We'd love for you to contribute to the SDK and to make it even better than it is today! Here are some pointers to get you started. + +Setting Up a Local Development Environment +------------------------------------------ + +* Install stack: +* `git clone https://github.com/instana/haskell-trace-sdk.git` (or create a fork on GitHub and clone your fork) +* `cd haskell-trace-sdk` +* `stack setup` +* `stack build` +* `stack exec instana-haskell-example-exe` + +The command `stack setup` will download the appropriate version of the compiler (GHC) if necessary in an isolated location (default ~/.stack) that won't interfere with any system-level GHC installations. `stack build` will build the project and `stack exec instana-haskell-example-exe` will start the example application, which tries to connect to an Instana agent and send trace data to it. + +After that, you can always use `stack build` to rebuild everything or use one of the convenience scripts located in the `bin` directory: + +* `example-app-build-and-run.sh`: Builds everything and starts the example application (see below). +* `example-app-watch.sh`: Watches the source files, rebuilds everything and starts the example application if a file changes. +* `integration-build-and-run.sh`: Builds and runs the integration tests. +* `integration-watch.sh`: Watches the source files, rebuilds and starts the integrations tests if a file changes. +* `unit-watch.sh`: Watches the source files, rebuilds and starts the unit tests if a file changes. +* `all-tests.sh`: Runs the unit and integration tests. +* `agent-stub-build-and-run.sh`: Builds and runs the agent stub (see below). +* `agent-stub-watch.sh`: Watches the agent stub's source files, rebuilds and starts the agent stub if a file changes. + +**All `watch` scripts require [entr](http://www.entrproject.org/) to be installed.** + +You can also start the individual executables directly via stack: + +* `stack exec instana-haskell-example-exe` +* `stack exec instana-haskell-agent-stub` + +Or you can run one of the test suites directly via stack: + +* `stack test instana-haskell-trace-sdk:instana-haskell-trace-sdk-unit-tests` +* `stack build instana-haskell-trace-sdk:instana-haskell-trace-sdk-integration-tests` + +Example Application +------------------ + +A trivial application that does nothing much except creating spans in an endless loop. It's behaviour depends on the environmentt variable `KEEP_ALIVE`. When `KEEP_ALIVE` is not set, the app will just run in an endless loop. When started with an explicit `KEEP_ALIVE=false stack exec instana-haskell-example-exe`, it will only run its loop once and then terminated. With `KEEP_ALIVE=60 stack exec instana-haskell-example-exe`, it will run its loop for 60 seconds before terminating. Note that you can also use this with the convenience scripts mentioned above, e.g., `KEEP_ALIVE=60 example-app-watch.sh`. + +Agent Stub +---------- + +A Haskell app that emulates the Instana agent. It is used in the integration tests, but it can also be used to replace the Instana agent for testing purposes, for example, when adding Instana tracing to your application. + +The agent stub can be configured with a number of environment variables: + +* `HOST` (default: `127.0.0.1`): The bind address of the agent stub. `127.0.0.1` is usually fine, but you can also use for example `*4` to bind to any IPv4 or IPv6 hostname, IPv4 preferred. See . +* `PORT` (default: `1302`): The port to bind to. +* `AGENT_NAME` (default: `Instana Agent`): Will be included in the response to `GET /` as the `Server` header. +* `STARTUP_DELAY` (default: `0`): An artificial startup delay in milliseconds, used for integration testing. +* `SIMULATE_CONNECTION_LOSS` (default: `false`): Used for integration testing. +* `SIMULATE_PID_TRANSLATION` (default: `false`): Used for integration testing. diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for instana-haskell-sdk + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +The MIT License + +Copyright (c) 2018 Instana, Inc. https://www.instana.com/ + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,192 @@ +# Instana Haskell Trace SDK   [![Build Status](https://travis-ci.org/instana/haskell-trace-sdk.svg?branch=master)](https://travis-ci.org/instana/haskell-trace-sdk) + +Monitor your Haskell application with [Instana](https://www.instana.com/)! 🎉 + +Disclaimer +---------- + +The Instana Haskell Trace SDK is a labor of love from some of our engineers and work on it is done in their spare time. Haskell is currently not a platform that we officialy support. The experience may differ from other programming languages and platforms that Instana actively supports (such as Java, .NET, Node.js, Python, Ruby, Go, PHP, ...). That said, the SDK is a fully functional piece of software, so don't let this disclaimer discourage you from using it. If you use Instana or consider using it and Haskell support is crucial for you, make sure to give us a ping and let's talk about it. + +What The Haskell Trace SDK Is And What It Is Not +------------------------------------------------ + +The Instana Haskell Trace SDK does not support automatic instrumentation/tracing in the way we support it in most other languages. Instead, the SDK enables you to create spans manually, much like the [Instana Trace SDK for Java](https://docs.instana.io/core_concepts/tracing/java_trace_sdk/) does. Besides offering a convenient API to create spans, the Haskell Trace SDK also takes care of establishing a connection to the Instana Agent and sending spans to the agent in an efficient way, that does not impede the performance of your production code. + +Installation +------------ + +**NOTE: Currently, the `instana-haskell-trace-sdk` has not been published on Hackage yet, so adding it to your dependencies will not work yet. It will be published soon. Stay tuned!** + +To use the Instana Haskell Trace SDK in your application, add `instana-haskell-trace-sdk` to your dependencies (for example to the `build-depends` section of your cabal file). + +Usage +----- + +### Initialization + +Before using the SDK, you need to initialize it once, usually during application startup. + +``` +import qualified Instana.SDK.SDK as InstanaSDK + +main :: IO () +main = do + -- ... initialize things ... + + -- initialize Instana + instana <- InstanaSDK.initInstana + + -- ... initialize more things +``` + +The value `instana :: Instana.SDK.SDK.InstanaContext` that is returned by `InstanaSDK.initInstana` is required for all further calls, that is, for creating spans that will be send to the agent. The SDK will try to connect to an agent (asynchronous, in a a separate thread) as soon as it receives the `initInstana` call. + +The SDK can be configured via environment variables or directly in the code by passing configuration parameters to the initialization function, or both. + +If you would like to pass configuration parameters programatically, use `initConfiguredInstana` instead of `initInstana`: + +``` +import qualified Instana.SDK.SDK as InstanaSDK + +main :: IO () +main = do + + -- Example snippet for using the Instana SDK and providing a configuration + -- (agent host, port, ...) directly in code. You only need to specify the + -- configuration values you are interested in and can omit everything else + -- (see https://www.yesodweb.com/book/settings-types). + let + config = + InstanaSDK.defaultConfig + { InstanaSDK.agentHost = Just "127.0.0.1" + , InstanaSDK.agentPort = Just 42699 + , InstanaSDK.forceTransmissionAfter = Just 1000 + , InstanaSDK.forceTransmissionStartingAt = Just 500 + , InstanaSDK.maxBufferedSpans = Just 1000 + } + instana <- InstanaSDK.initConfiguredInstana config +``` + +For configuration parameters that are omitted when creating the config record or are set to `Nothing`, the SDK will fall back to environment variables (see below) and then to default values. + +There are also [bracket-style](https://wiki.haskell.org/Bracket_pattern) variants of the initialization function, called `withInstana` and `withConfiguredInstana`: + +``` +import qualified Instana.SDK.SDK as InstanaSDK + +main :: IO () +main = do + InstanaSDK.withInstana runApp + +runApp :: InstanaContext -> IO () +runApp instana = do + -- do your thing here :-) +``` + +or, with bracket style and a configuration record: + +``` +import qualified Instana.SDK.SDK as InstanaSDK + +main :: IO () +main = do + let + config = + InstanaSDK.defaultConfig + { InstanaSDK.agentHost = Just "127.0.0.1" + , InstanaSDK.agentPort = Just 42699 + , InstanaSDK.forceTransmissionAfter = Just 1000 + , InstanaSDK.forceTransmissionStartingAt = Just 500 + , InstanaSDK.maxBufferedSpans = Just 1000 + } + + InstanaSDK.withConfiguredInstana config runApp + +runApp :: InstanaContext -> IO () +runApp instana = do + -- do your thing here :-) +``` + +### Creating Spans + +#### Bracket Style (High Level API) + +All functions starting with `with` accept (among other parameters) an IO action. The SDK will start a span before, then execute the given IO action and complete the span afterwards. Using this style is recommended over the low level API that requires you to start and complete spans yourself. + +* `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. +* `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. + +#### Low Level API/Explicit Start And Complete + +* `startRootEntry`: Starts an entry span that is the beginning of a trace (has no parent span). You will need to call `completeEntry` at some point. +* `startEntry`: Starts an entry span. You will need to call `completeEntry` at some point. +* `startExit`: Starts an exit span. You need to call `completeExit`/`completeExitWithData` at some point with the partial exit span value that is returned by this function. +* `completeEntry`: Finalizes an entry span. This will put the span into the SDK's span buffer for transmission to the Instana agent. +* `completeExit`: Finalizes an exit span. This will put the span into the SDK's span buffer for transmission to the Instana agent. + +### Configuration Via Environment Variables + +Instead of configuring the SDK programatically, as seen above, it can also be configured via environment variables: + +* `INSTANA_AGENT_HOST`: The IP or the host of the Instana agent to connect to. Default: 127.0.0.1. +* `INSTANA_AGENT_PORT`: The port of the Instana agent to connect to. Default: 42699. +* `INSTANA_AGENT_NAME`: When establishing a connection to the Instana agent, the SDK validates the Instana agent's `Server` HTTP response header. Should you have changed the Server name on the agent side, you can use this environment variable to provide the name to match that header against. +* `INSTANA_FORCE_TRANSMISSION_STARTING_AFTER`: Spans are usually buffered before being transmitted to the agent. This setting forces the transmission of all buffered spans after the given amount of milliseconds. Default: 1000. +* `INSTANA_FORCE_TRANSMISSION_STARTING_AT`: This setting forces the transmission of all buffered spans when the given number of spans has been buffered. +* `INSTANA_MAX_BUFFERED_SPANS`: Limits the number of spans to buffer. When the limit is reached, spans will be dropped. This setting is a safe guard against memory leaks from buffering excessive amounts of spans. It must be larger than `INSTANA_FORCE_TRANSMISSION_STARTING_AT`. +* `INSTANA_LOG_LEVEL`: See section "Configure Debug Logging". +* `INSTANA_LOG_LEVEL_STDOUT`: See section "Configure Debug Logging". +* `INSTANA_OVERRIDE_HSLOGGER_ROOT_HANDLER`: See section "Configure Debug Logging". + +### Configure Debug Logging + +If required, the Instana Haskell SDK can produce logs via [hslogger](http://hackage.haskell.org/package/hslogger). Under normal circumstances, the SDK does not emit any log output at all. It will only output log messages when logging is explicitly enabled via certain environment variables. This can be useful to troubleshoot tracing in production settings or during development. + +#### 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_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` + +Setting up hslogger correctly inside a library like the Instana Haskell SDK (as opposed to an application which has full control) can be tricky. For the Instana Haskell SDK to be able to correctly configure hslogger, it is important to know whether the app in question (or some part of it) already uses hslogger. In particular, does some part of the code set a handler on hslogger's root logger? Is a call like the following executed somewhere in the application? + +``` +import System.Log.Logger (rootLoggerName, setHandlers, updateGlobalLogger) + +updateGlobalLogger rootLoggerName $ setHandlers [...] +``` + +If this is the case, you can simply use `INSTANA_LOG_LEVEL` (or `INSTANA_LOG_LEVEL_STDOUT`) without further configuration. If the app in question does not use hslogger, that is, if no `setHandler` call on `rootLoggerName` is executed, you should also set +`INSTANA_OVERRIDE_HSLOGGER_ROOT_HANDLER` to a non-empty string (for example, `INSTANA_OVERRIDE_HSLOGGER_ROOT_HANDLER=true`). + +#### Troubleshooting Tracing In Production + +If your app already uses hslogger, use: + +* `INSTANA_LOG_LEVEL=DEBUG` + +Otherwise, use: + +* `INSTANA_LOG_LEVEL=DEBUG INSTANA_OVERRIDE_HSLOGGER_ROOT_HANDLER=true` + +#### Development + +During development (that is, when working on the Instana Haskell SDK), use either + +* `INSTANA_LOG_LEVEL_STDOUT=DEBUG` + +or + +* `INSTANA_LOG_LEVEL_STDOUT=DEBUG` +* `INSTANA_OVERRIDE_HSLOGGER_ROOT_HANDLER=true` + +depending on whether the application already uses and configures hslogger. The application `example-app` that is contained in the Instana Haskell SDK's repo configures hslogger, so simply using `INSTANA_LOG_LEVEL_STDOUT=DEBUG` is correct. + +Contributing +------------ + +See [CONTRIBUTING.md](https://github.com/instana/haskell-trace-sdk/blob/master/CONTRIBUTING.md). + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/example-app/Main.hs b/example-app/Main.hs new file mode 100644 --- /dev/null +++ b/example-app/Main.hs @@ -0,0 +1,178 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + + +import Control.Concurrent (threadDelay) +import Control.Monad (when) +import Instana.SDK.SDK (InstanaContext) +import qualified Instana.SDK.SDK as InstanaSDK +import System.Environment (lookupEnv) +import System.IO (Handle, stdout) +import System.Log.Formatter +import System.Log.Handler (setFormatter) +import System.Log.Handler.Simple (GenericHandler, fileHandler, + streamHandler) +import System.Log.Logger (Priority (..), rootLoggerName, + setHandlers, setLevel, + updateGlobalLogger) +import System.Log.Logger (infoM) +import Text.Read (readMaybe) + + +appLogger :: String +appLogger = "ExampleApp" + + +main :: IO () +main = do + initLogging + + -- Example snippet for using the Instana SDK and relying only on environment + -- variables/default values for the configuration. + InstanaSDK.withInstana runApp + + -- Example snippet for using the Instana SDK and providing a configuration + -- (agent host, port, ...) directly in code (falling back to environment + -- variables and then to default values). You only need to specify the + -- configuration values you are interested in and can omit everything else + -- (see https://www.yesodweb.com/book/settings-types). + -- + -- let + -- config = + -- InstanaSDK.defaultConfig + -- { InstanaSDK.agentHost = Just "127.0.0.1" + -- , InstanaSDK.agentPort = Just 42699 + -- , InstanaSDK.forceTransmissionAfter = Just 1000 + -- , InstanaSDK.forceTransmissionStartingAt = Just 500 + -- , InstanaSDK.maxBufferedSpans = Just 1000 + -- } + -- InstanaSDK.withConfiguredInstana config runApp + + +runApp :: InstanaContext -> IO () +runApp instana = do + startKeepAliveLoop instana + + +data KeepAlive = + No + | Indefinitely + | Seconds Int + +{-| Keeps the process alive by scheduling an endless loop. The intention is that +the agent has a chance to find the announcing process in the OS' process list. +-} +startKeepAliveLoop :: InstanaContext -> IO () +startKeepAliveLoop instana = do + keepAliveSetting <- lookupEnv "KEEP_ALIVE" + let + keepAliveMax = + if keepAliveSetting == Just "false" + then No + else + case keepAliveSetting of + Nothing -> Indefinitely + Just envVal -> + case readMaybe envVal of + Nothing -> Indefinitely + Just parsedInt -> Seconds parsedInt + case keepAliveMax of + No -> do + -- keep alive disabled, return no op to terminate immediately + infoM appLogger "KEEP_ALIVE expicitly disabled, terminating." + return () + Seconds s -> do + infoM appLogger $ "Keeping process alive for " ++ show s ++ " seconds." + keepAliveLoop instana (s * 10) 1 + Indefinitely -> do + infoM appLogger $ "Keeping process alive indefinitely " ++ + "(KEEP_ALIVE not explicitly specified or not parseable)." + keepAliveLoop instana (-1) 1 + + +keepAliveLoop :: InstanaContext -> Int -> Int -> IO () +keepAliveLoop instana maxIterations counter = do + + when (counter `mod` 20 == 0) $ do + createSpansUsingLowLevelApi instana + when (counter + 10 `mod` 20 == 0) $ do + createSpansUsingBracketApi instana + + when (counter `mod` 100 == 0) $ do + let + maxStr = + if maxIterations < 0 + then "" + else ("/" ++ (show (maxIterations `div` 10))) + infoM appLogger $ + "waiting [" ++ show (counter `div` 10) ++ maxStr ++ "]" + + -- delay by 100 ms + threadDelay $ 100 * 1000 + + if (maxIterations >= 0 && counter >= maxIterations) + then do + infoM appLogger $ + "waited for " ++ (show (maxIterations `div` 10)) ++ + " seconds, now terminating" + return () + else do + keepAliveLoop instana maxIterations (counter + 1) + + +createSpansUsingBracketApi :: InstanaContext -> IO () +createSpansUsingBracketApi instana = do + InstanaSDK.withRootEntry + instana + "haskell.dummy.root.entry" + (simulateExitCall instana) + return () + + +simulateExitCall :: InstanaContext -> IO () +simulateExitCall instana = + InstanaSDK.withExit + instana + "haskell.dummy.exit" + (putStrLn "Here be dragons!") + + +createSpansUsingLowLevelApi :: InstanaContext -> IO () +createSpansUsingLowLevelApi instana = do + -- Start an entry span (you would need to check if a trace ID and parent + -- span ID are already available, for example from HTTP headers of an + -- incoming request, and, if so, pass them on using InstanaSDK.startEntry + -- instead of InstanaSDK.startRootEntry + InstanaSDK.startRootEntry instana "haskell.dummy.root.entry" + InstanaSDK.startExit instana "haskell.dummy.exit" + + -- Now a real app would execute some exit call, say a DB call or an + -- HTTP call. + + -- mark the exit call as completed + InstanaSDK.completeExit instana + + -- mark the entry as completed and return + InstanaSDK.completeEntry instana + + return () + + +initLogging :: IO () +initLogging = do + updateGlobalLogger appLogger $ setLevel INFO + appFileHandler <- fileHandler "example-app.log" INFO + appStreamHandler <- streamHandler stdout INFO + let + formattedAppFileHandler = withFormatter appFileHandler + formattedAppStreamHandler = withFormatter appStreamHandler + updateGlobalLogger appLogger $ + setHandlers [ formattedAppFileHandler ] + updateGlobalLogger rootLoggerName $ + setHandlers [ formattedAppStreamHandler ] + + +withFormatter :: GenericHandler Handle -> GenericHandler Handle +withFormatter handler = setFormatter handler formatter + where formatter = simpleLogFormatter "{$time $loggername $prio} $msg" + diff --git a/instana-haskell-trace-sdk.cabal b/instana-haskell-trace-sdk.cabal new file mode 100644 --- /dev/null +++ b/instana-haskell-trace-sdk.cabal @@ -0,0 +1,295 @@ +name: instana-haskell-trace-sdk +version: 0.1.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/ +bug-reports: https://github.com/instana/haskell-trace-sdk/issues +author: Bastian Krol +maintainer: bastian.krol@instana.com +copyright: 2018 Instana, Inc. +category: Monitoring +license: MIT +license-file: LICENSE +build-type: Simple +stability: experimental +cabal-version: >= 1.10 + +extra-source-files: + ChangeLog.md + README.md + CONTRIBUTING.md + +source-repository head + type: git + location: https://github.com/instana/haskell-trace-sdk + +Flag dev + Description: development mode - warnings let compilation fail + Default: False + Manual: True + +library + hs-source-dirs: + src + build-depends: + base >=4.7 && <5 + , aeson + , aeson-extra + , bytestring + , containers + , directory + , ekg-core + , exceptions + , hslogger + , http-client + , http-client-tls + , http-types + , network + , process + , random + , regex-base + , regex-tdfa + , retry + , scientific + , stm + , sysinfo + , text + , time + , unix + , unordered-containers + , wai + if flag(dev) + ghc-options: + -Wall -Werror + else + ghc-options: + -Wall + exposed-modules: + Instana.SDK.Config + Instana.SDK.SDK + Instana.SDK.Span.EntrySpan + Instana.SDK.Span.ExitSpan + Instana.SDK.Span.NonRootEntry + Instana.SDK.Span.RootEntry + Instana.SDK.Span.Span + Instana.SDK.TracingHeaders + other-modules: + Instana.SDK.Internal.AgentConnection.AgentHostLookup + Instana.SDK.Internal.AgentConnection.AgentReady + Instana.SDK.Internal.AgentConnection.Announce + Instana.SDK.Internal.AgentConnection.ConnectLoop + Instana.SDK.Internal.AgentConnection.Json.AnnounceResponse + Instana.SDK.Internal.AgentConnection.Json.Util + Instana.SDK.Internal.AgentConnection.Paths + Instana.SDK.Internal.AgentConnection.ProcessInfo + Instana.SDK.Internal.AgentConnection.SchedFile + Instana.SDK.Internal.Command + Instana.SDK.Internal.Config + Instana.SDK.Internal.Context + Instana.SDK.Internal.FullSpan + Instana.SDK.Internal.Id + Instana.SDK.Internal.Logging + Instana.SDK.Internal.Metrics.Collector + Instana.SDK.Internal.Metrics.Compression + Instana.SDK.Internal.Metrics.Deltas + Instana.SDK.Internal.Metrics.Sample + Instana.SDK.Internal.Retry + Instana.SDK.Internal.Secrets + Instana.SDK.Internal.SpanStack + Instana.SDK.Internal.URL + Instana.SDK.Internal.Util + Instana.SDK.Internal.Worker + Paths_instana_haskell_trace_sdk + default-language: Haskell2010 + + +executable instana-haskell-example-exe + main-is: Main.hs + hs-source-dirs: + example-app + if flag(dev) + ghc-options: + -Wall -Werror -threaded -rtsopts "-with-rtsopts=-T -N " + else + ghc-options: + -Wall -threaded -rtsopts "-with-rtsopts=-T -N " + build-depends: + base >=4.7 && <5 + , hslogger + , instana-haskell-trace-sdk + default-language: Haskell2010 + + +test-suite instana-haskell-trace-sdk-unit-tests + -- We are not listing instana-haskell-trace-sdk as a dependency here but + -- instead list src as an additional hs-source-dir. This has the advantage + -- that we can test internal modules at the expense of needing to duplicate + -- all modules we want to test in other-modules and all dependencies + -- required for these modules in build-depends. Also, this modules will be + -- compiled twice (once for the library build and once for the test build). + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: + test/unit, src + if flag(dev) + ghc-options: + -Wall -Werror -threaded -rtsopts -with-rtsopts=-N -Wno-missing-home-modules + else + ghc-options: + -Wall -threaded -rtsopts -with-rtsopts=-N -Wno-missing-home-modules + build-depends: + base >=4.7 && <5 + , bytestring + , aeson + , aeson-extra + , directory + , ekg-core + , HUnit + , hslogger + , random + , regex-base + , regex-tdfa + , scientific + , text + , unordered-containers + other-modules: + -- the actual tests + Instana.SDK.Internal.AgentConnection.SchedFileTest + Instana.SDK.Internal.ConfigTest + Instana.SDK.Internal.IdTest + Instana.SDK.Internal.LoggingTest + Instana.SDK.Internal.Metrics.CompressionTest + Instana.SDK.Internal.Metrics.DeltasTest + Instana.SDK.Internal.SecretsTest + Instana.SDK.Internal.SpanStackTest + Instana.SDK.Internal.SpanTest + -- modules under test + Instana.SDK.Internal.Config + Instana.SDK.Internal.AgentConnection.SchedFile + Instana.SDK.Internal.Id + Instana.SDK.Internal.Logging + Instana.SDK.Internal.Metrics.Compression + Instana.SDK.Internal.Metrics.Deltas + Instana.SDK.Internal.Secrets + Instana.SDK.Internal.SpanStack + Instana.SDK.Span.Span + -- dependencies of modules under test + Instana.SDK.Config + Instana.SDK.Internal.Metrics.Sample + Instana.SDK.Internal.Util + Instana.SDK.Span.EntrySpan + Instana.SDK.Span.ExitSpan + Instana.SDK.Span.NonRootEntry + Instana.SDK.Span.RootEntry + default-language: Haskell2010 + + +executable instana-haskell-agent-stub + main-is: Main.hs + hs-source-dirs: + test/agent-stub, test/shared + if flag(dev) + ghc-options: + -Wall -Werror -threaded -rtsopts -with-rtsopts=-N + else + ghc-options: + -Wall -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.7 && <5 + , aeson + , hslogger + , servant + , servant-server + , text + , time + , transformers + , unix + , wai + , warp + other-modules: + Instana.SDK.AgentStub.API + , Instana.SDK.AgentStub.Config + , Instana.SDK.AgentStub.DiscoveryRequest + , Instana.SDK.AgentStub.DiscoveryResponse + , Instana.SDK.AgentStub.EntityDataRequest + , Instana.SDK.AgentStub.Logging + , Instana.SDK.AgentStub.Main + , Instana.SDK.AgentStub.Recorders + , Instana.SDK.AgentStub.Server + , Instana.SDK.AgentStub.StubAPI + , Instana.SDK.AgentStub.StubServer + , Instana.SDK.AgentStub.TraceRequest + , Instana.SDK.AgentStub.Util + default-language: Haskell2010 + + +test-suite instana-haskell-trace-sdk-integration-tests + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: + test/integration, test/shared + if flag(dev) + ghc-options: + -Wall -Werror -threaded -rtsopts "-with-rtsopts=-T -N " + else + ghc-options: + -Wall -threaded -rtsopts "-with-rtsopts=-T -N " + build-depends: + base >=4.7 && <5 + , aeson + , bytestring + , exceptions + , hslogger + , HUnit + , http-client + , http-types + , instana-haskell-trace-sdk + , process + , retry + , text + , unix + , unordered-containers + other-modules: + Instana.SDK.AgentStub.DiscoveryRequest + , Instana.SDK.AgentStub.EntityDataRequest + , Instana.SDK.AgentStub.TraceRequest + , Instana.SDK.IntegrationTest.BracketApi + , Instana.SDK.IntegrationTest.Connection + , Instana.SDK.IntegrationTest.HUnitExtra + , Instana.SDK.IntegrationTest.HttpHelper + , Instana.SDK.IntegrationTest.HttpTracing + , Instana.SDK.IntegrationTest.LowLevelApi + , Instana.SDK.IntegrationTest.Metrics + , Instana.SDK.IntegrationTest.Runner + , Instana.SDK.IntegrationTest.Suite + , Instana.SDK.IntegrationTest.TestHelper + , Instana.SDK.IntegrationTest.TestSuites + , Instana.SDK.IntegrationTest.Util + default-language: Haskell2010 + + +executable instana-haskell-test-wai-server + main-is: Main.hs + hs-source-dirs: + test/apps/wai + if flag(dev) + ghc-options: + -Wall -Werror -threaded -rtsopts "-with-rtsopts=-T -N " + else + ghc-options: + -Wall -threaded -rtsopts "-with-rtsopts=-T -N " + build-depends: + base >=4.7 && <5 + , aeson + , binary + , bytestring + , hslogger + , http-client + , http-types + , instana-haskell-trace-sdk + , text + , unix + , wai + , warp + default-language: Haskell2010 + diff --git a/src/Instana/SDK/Config.hs b/src/Instana/SDK/Config.hs new file mode 100644 --- /dev/null +++ b/src/Instana/SDK/Config.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE DeriveGeneric #-} +{-| +Module : Instana.SDK.Config +Description : Provides configuration records that can be used to control the initialization of the SDK +-} +module Instana.SDK.Config + -- Maintenance note: accessor functions need to be reexported in SDK.hs + ( Config + , agentHost + , agentPort + , agentName + , defaultConfig + , forceTransmissionAfter + , forceTransmissionStartingAt + , maxBufferedSpans + ) where + + +import GHC.Generics + + +{-| Configuration for a the Instana SDK. Please use the 'defaultConfig' +function and then modify individual settings via record syntax For more +information, see . +-} +data Config = Config + { -- | IP or host name of the Instana agent + agentHost :: Maybe String + -- | Port of the Instana agent + , agentPort :: Maybe Int + -- | When establishing a connection to the Instana agent, the SDK validates + -- the Instana agent's `Server` HTTP response header. Should you have + -- changed the Server name on the agent side, you can use parameter to + -- provide the name to match that header against. + , agentName :: Maybe String + -- | Spans are usually buffered before being transmitted to the agent. This + -- setting forces the transmission of all buffered spans after the given + -- amount of milliseconds. Default: 1000. + , forceTransmissionAfter :: Maybe Int + -- | This setting forces the transmission of all buffered spans when the + -- given number of spans has been buffered. + , forceTransmissionStartingAt :: Maybe Int + -- | Limits the number of spans to buffer. When the limit is reached, spans + -- will be dropped. This setting is a safe guard against memory leaks from + -- buffering excessive amounts of spans. It must be larger than + -- forceTransmissionStartingAt. + , maxBufferedSpans :: Maybe Int + } deriving (Eq, Generic) + + +{-| Populates all config values as Nothing, so that the Instana SDK relies on +environment variables or on its default config values (in this order) +internally. +-} +defaultConfig :: Config +defaultConfig = + Config + { agentHost = Nothing + , agentPort = Nothing + , agentName = Nothing + , forceTransmissionAfter = Nothing + , forceTransmissionStartingAt = Nothing + , maxBufferedSpans = Nothing + } + diff --git a/src/Instana/SDK/Internal/AgentConnection/AgentHostLookup.hs b/src/Instana/SDK/Internal/AgentConnection/AgentHostLookup.hs new file mode 100644 --- /dev/null +++ b/src/Instana/SDK/Internal/AgentConnection/AgentHostLookup.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-| +Module : Instana.SDK.Internal.AgentConnection.AgentHostLookup +Description : Handles the agent host lookup phase for establishing the +connection to the agent. +-} +module Instana.SDK.Internal.AgentConnection.AgentHostLookup + ( lookupAgentHost + ) where + + +import qualified Control.Concurrent.STM as STM +import Control.Exception (SomeException, + catch) +import Data.ByteString.Char8 (unpack) +import Data.Char (isSpace) +import qualified Data.List as List +import qualified Network.HTTP.Client as HTTP +import qualified Network.HTTP.Types.Header as Header +import System.Exit (ExitCode (ExitSuccess)) +import System.Log.Logger (debugM) +import System.Process as Process + +import qualified Instana.SDK.Internal.AgentConnection.Announce as Announce +import Instana.SDK.Internal.AgentConnection.ProcessInfo (ProcessInfo) +import qualified Instana.SDK.Internal.Config as InternalConfig +import Instana.SDK.Internal.Context (ConnectionState (..), + InternalContext) +import qualified Instana.SDK.Internal.Context as InternalContext +import Instana.SDK.Internal.Logging (instanaLogger) +import qualified Instana.SDK.Internal.Retry as Retry +import qualified Instana.SDK.Internal.URL as URL + + +type SuccessfullHost = (String, Int) + + +-- |Starts the agent host lookup phase. +lookupAgentHost :: + InternalContext + -> ProcessInfo + -> IO () +lookupAgentHost context processInfo = do + debugM instanaLogger "Starting agent host lookup." + result <- + Retry.retryUntilRight + Retry.agentHostLookupRetryPolicy + (tryAll context) + case result of + Right successfulHost -> do + debugM instanaLogger $ + "Found an agent to connect to: " ++ show successfulHost ++ + ", starting sensor-agent handshake." + STM.atomically $ + STM.writeTVar + (InternalContext.connectionState context) + (Unannounced successfulHost) + + -- transition to next phase of sensor-agent handshake + Announce.announce context processInfo + Left _ -> do + -- Actually, this line should never be reached, as the agent host lookup + -- is retried indefinitely. + debugM instanaLogger "Could not find an agent to connect to." + STM.atomically $ STM.writeTVar + (InternalContext.connectionState context) + Unconnected + + +tryAll :: InternalContext -> IO (Either String SuccessfullHost) +tryAll context = do + resultConfiguredHost <- tryConfiguredHost context + case resultConfiguredHost of + Right _ -> + return resultConfiguredHost + Left errc -> do + debugM instanaLogger $ errc ++ ", trying default gateway next." + resultDefaultGateway <- tryDefaultGateway context + case resultDefaultGateway of + Right _ -> + return resultDefaultGateway + Left errdg -> do + debugM instanaLogger errdg + return resultDefaultGateway + + +tryConfiguredHost :: InternalContext -> IO (Either String SuccessfullHost) +tryConfiguredHost context = do + let + config = InternalContext.config context + host = InternalConfig.agentHost config + port = InternalConfig.agentPort config + tryHost context host port + + +tryDefaultGateway :: InternalContext -> IO (Either String SuccessfullHost) +tryDefaultGateway context = do + let + config = InternalContext.config context + port = InternalConfig.agentPort config + defaultGateway <- readDefaultGateway + case defaultGateway of + Right gatewayHost -> + tryHost context gatewayHost port + Left err -> + return $ Left err + + +tryHost :: + InternalContext + -> String + -> Int + -> IO (Either String SuccessfullHost) +tryHost context host port = do + let + config = InternalContext.config context + expectedServerHeader = InternalConfig.agentName config + manager = InternalContext.httpManager context + agentRootUrl = URL.mkHttp host port "" + agentRootRequest <- HTTP.parseUrlThrow $ show agentRootUrl + let + agentRootAction = HTTP.httpLbs agentRootRequest manager + catch + (do + response <- agentRootAction + let + headers = HTTP.responseHeaders response + serverHeaderTuple = List.find (\(h, _) -> h == Header.hServer) headers + serverHeaderValue = (unpack . snd) <$> serverHeaderTuple + if serverHeaderValue == Just expectedServerHeader + then do + return $ Right (host, port) + else do + return $ Left $ + "Host at " ++ show agentRootUrl ++ " did not respond with " ++ + "expected agent header but with: " ++ show serverHeaderValue + ) + (\e -> do + let + _ = (e :: SomeException) + return $ Left $ + "Could not reach agent at " ++ show agentRootUrl + ) + + +readDefaultGateway :: IO (Either String String) +readDefaultGateway = do + let + cmd = "/sbin/ip route | awk '/default/ { print $3 }'" + stdIn = "" + (exitCode, stdOut, stdErr) <- + Process.readCreateProcessWithExitCode (Process.shell cmd) stdIn + if exitCode /= ExitSuccess || stdErr /= "" + then + return $ Left $ "Failed to retrieve default gateway: " ++ stdErr + else + return $ Right $ trim stdOut + where + trim = List.dropWhileEnd isSpace . dropWhile isSpace + diff --git a/src/Instana/SDK/Internal/AgentConnection/AgentReady.hs b/src/Instana/SDK/Internal/AgentConnection/AgentReady.hs new file mode 100644 --- /dev/null +++ b/src/Instana/SDK/Internal/AgentConnection/AgentReady.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE OverloadedStrings #-} +{-| +Module : Instana.SDK.Internal.AgentConnection.AgentReady +Description : Handles the agent ready phase for establishing the connection to +the agent. +-} +module Instana.SDK.Internal.AgentConnection.AgentReady + ( waitUntilAgentIsReadyToAcceptData + ) where + + +import qualified Control.Concurrent.STM as STM +import Control.Exception (SomeException, + catch) +import Data.ByteString.Lazy (ByteString) +import qualified Network.HTTP.Client as HTTP +import System.Log.Logger (debugM, + infoM, + warningM) + +import Instana.SDK.Internal.AgentConnection.Json.AnnounceResponse (AnnounceResponse) +import qualified Instana.SDK.Internal.AgentConnection.Json.AnnounceResponse as AnnounceResponse +import Instana.SDK.Internal.AgentConnection.Json.Util (emptyResponseDecoder) +import Instana.SDK.Internal.AgentConnection.Paths (haskellEntityDataPathPrefix) +import Instana.SDK.Internal.AgentConnection.ProcessInfo (ProcessInfo) +import Instana.SDK.Internal.Context (ConnectionState (..), + InternalContext) +import qualified Instana.SDK.Internal.Context as InternalContext +import Instana.SDK.Internal.Logging (instanaLogger) +import qualified Instana.SDK.Internal.Metrics.Collector as MetricsCollector +import qualified Instana.SDK.Internal.Retry as Retry +import qualified Instana.SDK.Internal.URL as URL + + +-- |Starts the connection establishment phase where we wait for the agent to +-- signal that it is ready to accept data. +waitUntilAgentIsReadyToAcceptData :: + InternalContext + -> String + -> ProcessInfo + -> AnnounceResponse + -> IO () +waitUntilAgentIsReadyToAcceptData + context + originalPidStr + processInfo + announceResponse = do + debugM instanaLogger "Waiting until the agent is ready to accept data." + connectionState <- + STM.atomically $ STM.readTVar $ InternalContext.connectionState context + case connectionState of + Announced hostAndPort -> + waitForAgent + context + hostAndPort + originalPidStr + processInfo + announceResponse + _ -> do + warningM instanaLogger $ + "Reached illegal state in agent ready, announce did not " ++ + "yield a host and port. Connection state is " ++ show connectionState ++ + ". Will retry later." + STM.atomically $ STM.writeTVar + (InternalContext.connectionState context) + Unconnected + return () + + +waitForAgent :: + InternalContext + -> (String, Int) + -> String + -> ProcessInfo + -> AnnounceResponse + -> IO () +waitForAgent + context + (host, port) + originalPidStr + processInfo + announceResponse = do + let + translatedPidStr = show $ AnnounceResponse.pid announceResponse + pidTranslationStr = + if translatedPidStr == originalPidStr + then translatedPidStr + else "(" ++ originalPidStr ++ " => " ++ translatedPidStr ++ ")" + acceptDataUrl = + URL.mkHttp host port (haskellEntityDataPathPrefix ++ translatedPidStr) + agentReadyRequestBase <- HTTP.parseUrlThrow $ show acceptDataUrl + let + acceptDataRequest = agentReadyRequestBase + { HTTP.method = "HEAD" + , HTTP.requestHeaders = + [ ("Accept", "application/json") + , ("Content-Type", "application/json; charset=UTF-8'") + ] + } + manager = InternalContext.httpManager context + acceptDataRequestAction :: IO (HTTP.Response ByteString) + acceptDataRequestAction = HTTP.httpLbs acceptDataRequest manager + + success <- + catch + (Retry.retryRequest + Retry.acceptDataRetryPolicy + emptyResponseDecoder + acceptDataRequestAction + ) + (\e -> do + warningM instanaLogger $ show (e :: SomeException) + return False + ) + -- if 200 <= statusCode <= 299 then we assume everything is sweet and we + -- transition to next state + + if success + then do + metricsStore <- + MetricsCollector.registerMetrics + translatedPidStr + processInfo + (InternalContext.sdkStartTime context) + let + state = + InternalContext.mkAgentReadyState + (host, port) + announceResponse + metricsStore + STM.atomically $ + STM.writeTVar (InternalContext.connectionState context) state + infoM instanaLogger $ + "🎉 agent connection established for process " ++ pidTranslationStr ++ + " 🎉" + return () + else do + warningM instanaLogger $ + "Could not establish agent connection for process " ++ + pidTranslationStr ++ " (waiting for agent ready state failed), will " ++ + "retry later." + STM.atomically $ STM.writeTVar + (InternalContext.connectionState context) + Unconnected + diff --git a/src/Instana/SDK/Internal/AgentConnection/Announce.hs b/src/Instana/SDK/Internal/AgentConnection/Announce.hs new file mode 100644 --- /dev/null +++ b/src/Instana/SDK/Internal/AgentConnection/Announce.hs @@ -0,0 +1,181 @@ +{-# LANGUAGE OverloadedStrings #-} +{-| +Module : Instana.SDK.Internal.AgentConnection.Announce +Description : Handles the announce phase for establishing the connection to the +agent. +-} +module Instana.SDK.Internal.AgentConnection.Announce + ( announce + ) where + + +import qualified Control.Concurrent.STM as STM +import Control.Exception (SomeException, + catch) +import Data.Aeson ((.=)) +import qualified Data.Aeson as Aeson +import Data.ByteString.Lazy (ByteString) +import Data.Maybe (isJust) +import qualified Network.HTTP.Client as HTTP +import System.Log.Logger (debugM, + warningM) +import qualified System.Posix.Files as PosixFiles + +import Instana.SDK.Internal.AgentConnection.AgentReady as AgentReady +import Instana.SDK.Internal.AgentConnection.Json.AnnounceResponse (AnnounceResponse) +import Instana.SDK.Internal.AgentConnection.Paths +import Instana.SDK.Internal.AgentConnection.ProcessInfo (ProcessInfo) +import qualified Instana.SDK.Internal.AgentConnection.ProcessInfo as ProcessInfo +import Instana.SDK.Internal.Context (ConnectionState (..), + InternalContext) +import qualified Instana.SDK.Internal.Context as InternalContext +import Instana.SDK.Internal.Logging (instanaLogger) +import qualified Instana.SDK.Internal.Retry as Retry +import qualified Instana.SDK.Internal.URL as URL + + +-- |Starts the announce phase. +announce :: + InternalContext + -> ProcessInfo + -> IO () +announce context processInfo = do + debugM instanaLogger "Starting to announce process to agent." + connectionState <- + STM.atomically $ STM.readTVar $ InternalContext.connectionState context + case connectionState of + Unannounced hostAndPort -> + announceToAgent context hostAndPort processInfo + _ -> do + warningM instanaLogger $ + "Reached illegal state in announce, agent host lookup did not " ++ + "yield a host and port. Connection state is " ++ show connectionState ++ + ". Will retry later." + STM.atomically $ STM.writeTVar + (InternalContext.connectionState context) + Unconnected + return () + + +announceToAgent :: + InternalContext + -> (String, Int) + -> ProcessInfo + -> IO () +announceToAgent context (host, port) processInfo = do + fileDescriptor <- + STM.atomically $ STM.readTVar $ InternalContext.fileDescriptor context + let + manager = InternalContext.httpManager context + discoveryUrl = + URL.mkHttp host port haskellDiscoveryPath + nonContainerPid = ProcessInfo.pidString processInfo + (pidStr, pidFromParentNS) = + case ProcessInfo.parentNsPid processInfo of + Just parentPid -> + (parentPid, parentPid == nonContainerPid) + Nothing -> + (nonContainerPid, False) + maybeFileDescriptorString = show <$> fileDescriptor + maybeInodeLinkPath = + (\fdStr -> "/proc/" ++ nonContainerPid ++ "/fd/" ++ fdStr) <$> + maybeFileDescriptorString + discoveryRequestBase <- HTTP.parseUrlThrow $ show discoveryUrl + inode <- + case maybeInodeLinkPath of + Just inodeLinkPath -> + catch + (do + i <- PosixFiles.readSymbolicLink inodeLinkPath + return $ Just i + ) + (\e -> do + debugM instanaLogger $ + "Could not obtain inode for process matching from " ++ + inodeLinkPath ++ ": " ++ show (e :: SomeException) + return Nothing + ) + Nothing -> + return Nothing + + let + haskellProcess = + Aeson.object + [ "pid" .= pidStr + , "pidFromParentNS" .= pidFromParentNS + , "progName" .= ProcessInfo.programName processInfo + , "execPath" .= ProcessInfo.executablePath processInfo + , "args" .= ProcessInfo.arguments processInfo + , "fd" .= maybeFileDescriptorString + , "inode" .= inode + ] + + announceRequest = discoveryRequestBase + { HTTP.method = "PUT" + , HTTP.requestBody = HTTP.RequestBodyLBS $ Aeson.encode haskellProcess + , HTTP.requestHeaders = + [ ("Accept", "application/json") + , ("Content-Type", "application/json; charset=UTF-8'") + ] + } + announceRequestAction = HTTP.httpLbs announceRequest manager + + maybeAnnounceResponse <- + catch + (Retry.retryRequest + Retry.announceRetryPolicy + decodeAnnounceResponse + announceRequestAction + ) + (\e -> do + warningM instanaLogger $ show (e :: SomeException) + return Nothing + ) + + -- maybeAnnounceResponse is guaranteed to be Just _ if request succeeded and + -- response was parsed succesfully, it is only Nothing when an exception + -- has been catched, which should actually never happen, because we retry + -- indefinitely. + if isJust maybeAnnounceResponse + then do + let + Just announceResponse = maybeAnnounceResponse + STM.atomically $ + STM.writeTVar (InternalContext.connectionState context) $ + Announced (host, port) + debugM instanaLogger $ + "Haskell process " ++ pidStr ++ + " has been successfully announced to agent at " ++ show (host, port) ++ + ", now waiting for the agent to be ready to accept data." + + -- transition to next phase of sensor-agent handshake + AgentReady.waitUntilAgentIsReadyToAcceptData + context + pidStr + processInfo + announceResponse + else do + warningM instanaLogger $ + "Could not establish agent connection for process " ++ pidStr ++ + " (announce failed), will retry later." + STM.atomically $ STM.writeTVar + (InternalContext.connectionState context) + Unconnected + + +{-| Decodes the JSON response returned by the announce request. +-} +decodeAnnounceResponse :: + HTTP.Response ByteString + -> IO (Maybe AnnounceResponse) +decodeAnnounceResponse response = do + let + body = HTTP.responseBody response + maybeParsed :: Maybe AnnounceResponse + maybeParsed = Aeson.decode body + case maybeParsed of + Just _ -> do + return maybeParsed + Nothing -> + fail $ "Can't parse announce response" ++ (show body) + diff --git a/src/Instana/SDK/Internal/AgentConnection/ConnectLoop.hs b/src/Instana/SDK/Internal/AgentConnection/ConnectLoop.hs new file mode 100644 --- /dev/null +++ b/src/Instana/SDK/Internal/AgentConnection/ConnectLoop.hs @@ -0,0 +1,172 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-| +Module : Instana.SDK.Internal.AgentConnection.ConnectLoop +Description : Establishes a connection to the agent. +-} +module Instana.SDK.Internal.AgentConnection.ConnectLoop + ( initConnectLoop + ) where + + +import qualified Control.Concurrent as Concurrent +import qualified Control.Concurrent.STM as STM +import Control.Exception (SomeException, + catch) +import Control.Monad (forever) +import Data.Maybe (isNothing) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as TextIO +import qualified System.Environment as Environment +import System.Log.Logger (debugM, + infoM, + warningM) +import qualified System.Posix.Process as PosixProcess + +import qualified Instana.SDK.Internal.AgentConnection.AgentHostLookup as AgentHostLookup +import Instana.SDK.Internal.AgentConnection.ProcessInfo (ProcessInfo (ProcessInfo)) +import qualified Instana.SDK.Internal.AgentConnection.ProcessInfo as ProcessInfo +import Instana.SDK.Internal.AgentConnection.SchedFile (parsePidFromSchedFile) +import Instana.SDK.Internal.Context (ConnectionState (..), + InternalContext) +import qualified Instana.SDK.Internal.Context as InternalContext +import Instana.SDK.Internal.Logging (instanaLogger) + + +{-| Kick of a thread that loops endlessly and checks once in a while if the +agent connection is still up. If not, a connection attempt will be initiated. +The first attempt is made immediately when calling this. +-} +initConnectLoop :: InternalContext -> IO () +initConnectLoop context = do + pid <- PosixProcess.getProcessID + progName <- Environment.getProgName + execPath <- Environment.getExecutablePath + args <- Environment.getArgs + let + pidStr = show pid + cpuSetFileContent <- getCpuSetFileContent pidStr + parentNsPid <- getPidFromParentNamespace pidStr + let + processInfo = + ProcessInfo + { ProcessInfo.pidString = pidStr + , ProcessInfo.programName = progName + , ProcessInfo.executablePath = execPath + , ProcessInfo.arguments = args + , ProcessInfo.cpuSetFileContent = cpuSetFileContent + , ProcessInfo.parentNsPid = parentNsPid + } + if isNothing parentNsPid then + warningM instanaLogger $ "Could not parse PID from sched file. " ++ + "Discovery might not work if this process is running inside a " ++ + "container." + else + if (Just pidStr) == parentNsPid then + debugM instanaLogger $ + "PID in sched file matches process PID. Probably not running inside " ++ + "a PID namespace" + else do + let + Just parentPid = parentNsPid + infoM instanaLogger $ "Changing PID from " ++ pidStr ++ " to " ++ + parentPid ++ + " due to successful identification of PID in parent namespace." + debugM instanaLogger $ "discovered process info " ++ show processInfo + + -- connection loop works as follows: + -- - try to connect to an an agent at either the agent host/port received via + -- configuration, environment variables, default (127.0.0.1:42699) or default + -- gateway + -- - establishAgentConnection tries to connect to the agent by issuing + -- a POST to /com.instana.plugin.haskell.discovery + -- - establishAgentConnection only ever terminates if it has been successful, + -- then we have switched to announced state. + -- - after that, establishAgentConnection is called every 5 seconds, + -- - if the connection is still up, establishAgentConnection does nothing and + -- returns immediately, + -- - should the connection have been lost, the cycle starts again, that is, + -- establishAgentConnection will retry the POST forever and only terminate + -- after success. + forever $ do + establishAgentConnectionSafe context processInfo + Concurrent.threadDelay $ 5 * 1000 * 1000 + + +establishAgentConnectionSafe :: + InternalContext + -> ProcessInfo + -> IO () +establishAgentConnectionSafe context processInfo = + catch + (establishAgentConnection context processInfo) + -- exceptions in establishAgentConnection must not kill the loop, so we just + -- catch everything + (\e -> warningM instanaLogger $ show (e :: SomeException)) + + +establishAgentConnection :: + InternalContext + -> ProcessInfo + -> IO () +establishAgentConnection context processInfo = do + currentState <- STM.atomically $ + STM.readTVar (InternalContext.connectionState context) + -- Do nothing if a connection attempt is already in progress or connection has + -- already been established. + if currentState /= Unconnected + then + return () + else do + STM.atomically $ STM.writeTVar + (InternalContext.connectionState context) + AgentHostLookup + debugM instanaLogger $ "agent connection is not up, attempting reconnect" + -- Initial status: Unconnected + -- step 1: do agent host looup (retry forever until an agent has + -- been found) + -- New status: Unannounced + -- step 2: announce request (retry 3 times with 200 ms delay) + -- New status: Announced + -- step 3: check whether agent is ready to accept data (retry 10 times + -- with 10 second delay) + -- New status: Connected + -- If anything fails in between, go back to "Unconnected" + AgentHostLookup.lookupAgentHost context processInfo + + +getCpuSetFileContent :: String -> IO (Maybe Text) +getCpuSetFileContent pidStr = do + let + cpuSetPath = "/proc/" ++ pidStr ++ "/cpuset" + catch + ( do + content <- TextIO.readFile cpuSetPath + -- paranoid check - if the cpusets file for whatever reason is really big, + -- we don't want to send it to the agent at all. + if T.length content >= 2000 then + return Nothing + else + return $ Just content + ) + (\(_ :: SomeException) -> do + debugM instanaLogger $ "Can't read " ++ cpuSetPath ++ ", process " ++ + "is probably not running in a container." + return Nothing + ) + + +getPidFromParentNamespace :: String -> IO (Maybe String) +getPidFromParentNamespace pidStr = do + let + schedFilePath = "/proc/" ++ pidStr ++ "/sched" + catch + ( do + schedFileContent <- readFile schedFilePath + return $ parsePidFromSchedFile schedFileContent + ) + (\(_ :: SomeException) -> do + debugM instanaLogger $ "Can't read " ++ schedFilePath ++ "." + return Nothing + ) + diff --git a/src/Instana/SDK/Internal/AgentConnection/Json/AnnounceResponse.hs b/src/Instana/SDK/Internal/AgentConnection/Json/AnnounceResponse.hs new file mode 100644 --- /dev/null +++ b/src/Instana/SDK/Internal/AgentConnection/Json/AnnounceResponse.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE DeriveGeneric #-} +{-| +Module : Instana.SDK.Internal.AgentConnection.Json.AnnounceResponse +Description : Aeson type for the agent's announce response +-} +module Instana.SDK.Internal.AgentConnection.Json.AnnounceResponse + ( AnnounceResponse(..) + ) where + + +import Data.Aeson (FromJSON) +import Data.Text (Text) +import GHC.Generics + +import Instana.SDK.Internal.Secrets (SecretsMatcher) + + +-- |Holds the agent's response to the announce request. +data AnnounceResponse = AnnounceResponse + { pid :: Int + , agentUuid :: Text + , extraHeaders :: Maybe [Text] + , secrets :: SecretsMatcher + } deriving (Eq, Show, Generic) + +instance FromJSON AnnounceResponse + diff --git a/src/Instana/SDK/Internal/AgentConnection/Json/Util.hs b/src/Instana/SDK/Internal/AgentConnection/Json/Util.hs new file mode 100644 --- /dev/null +++ b/src/Instana/SDK/Internal/AgentConnection/Json/Util.hs @@ -0,0 +1,15 @@ +{-| +Module : Instana.SDK.Internal.AgentConnection.Json.Util +Description : A utility for JSON encoding/decoding. +-} +module Instana.SDK.Internal.AgentConnection.Json.Util where + + +import Data.ByteString.Lazy (ByteString) +import qualified Network.HTTP.Client as HTTP + + +-- |Creates a decoder for HTTP responses without a body. +emptyResponseDecoder :: HTTP.Response ByteString -> IO Bool +emptyResponseDecoder _ = + return True diff --git a/src/Instana/SDK/Internal/AgentConnection/Paths.hs b/src/Instana/SDK/Internal/AgentConnection/Paths.hs new file mode 100644 --- /dev/null +++ b/src/Instana/SDK/Internal/AgentConnection/Paths.hs @@ -0,0 +1,21 @@ +{-| +Module : Instana.SDK.Internal.AgentConnection.Paths +Description : Some URL paths. +-} +module Instana.SDK.Internal.AgentConnection.Paths where + + +-- | discovery resource +haskellDiscoveryPath :: String +haskellDiscoveryPath = "com.instana.plugin.haskell.discovery" + + +-- | entity data prefix +haskellEntityDataPathPrefix :: String +haskellEntityDataPathPrefix = "com.instana.plugin.haskell." + + +-- | trace resource +haskellTracePluginPath :: String +haskellTracePluginPath = "com.instana.plugin.haskell/traces" + diff --git a/src/Instana/SDK/Internal/AgentConnection/ProcessInfo.hs b/src/Instana/SDK/Internal/AgentConnection/ProcessInfo.hs new file mode 100644 --- /dev/null +++ b/src/Instana/SDK/Internal/AgentConnection/ProcessInfo.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE DeriveGeneric #-} +{-| +Module : Instana.SDK.Internal.AgentConnection.ProcessInfo +Description : Holds meta data about an OS process. +-} +module Instana.SDK.Internal.AgentConnection.ProcessInfo + ( ProcessInfo(..) + ) where + + +import Data.Text (Text) +import GHC.Generics + + +-- |Holds meta data about an OS process. +data ProcessInfo = + ProcessInfo + { pidString :: String + , programName :: String + , executablePath :: String + , arguments :: [String] + , cpuSetFileContent :: Maybe Text + , parentNsPid :: Maybe String + } deriving (Eq, Generic, Show) + diff --git a/src/Instana/SDK/Internal/AgentConnection/SchedFile.hs b/src/Instana/SDK/Internal/AgentConnection/SchedFile.hs new file mode 100644 --- /dev/null +++ b/src/Instana/SDK/Internal/AgentConnection/SchedFile.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-| +Module : Instana.SDK.Internal.AgentConnection.SchedFile +Description : Parses the content of the sched file. +-} +module Instana.SDK.Internal.AgentConnection.SchedFile + ( parsePidFromSchedFile + ) where + + +import qualified Text.Regex.Base.RegexLike as RegexBase +import qualified Text.Regex.TDFA as Regex +import Text.Regex.TDFA.String (Regex) +import qualified Text.Regex.TDFA.String as RegexString + + +parsePidFromSchedFile :: String -> Maybe String +parsePidFromSchedFile schedFileContent = + let + allMatches :: [[String]] + allMatches = RegexBase.match schedFilePidPattern schedFileContent + in + if null allMatches then + Nothing + else do + let + (firstMatchWithCaptures :: [String]) = head allMatches + if (length firstMatchWithCaptures) < 2 then + Nothing + else + Just $ head $ tail $ firstMatchWithCaptures + + +schedFilePidPattern :: Regex +schedFilePidPattern = + let + compiledPattern = + RegexString.compile + (Regex.defaultCompOpt + { Regex.caseSensitive = False + , Regex.multiline = True + } + ) + Regex.defaultExecOpt + "^[^(]+\\(([0-9]+)," + Right pattern = compiledPattern + in + pattern + diff --git a/src/Instana/SDK/Internal/Command.hs b/src/Instana/SDK/Internal/Command.hs new file mode 100644 --- /dev/null +++ b/src/Instana/SDK/Internal/Command.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE DeriveGeneric #-} +{-| +Module : Instana.SDK.Internal.Command +Description : Commands that can be send to the worker +-} +module Instana.SDK.Internal.Command + ( Command(..) + ) where + + +import Instana.SDK.Span.EntrySpan (EntrySpan) +import Instana.SDK.Span.ExitSpan (ExitSpan) + + +-- |A command that can be send to the worker. +data Command = + -- |CompleteEntry entrySpan + CompleteEntry EntrySpan + -- |CompleteExit exitSpan + | CompleteExit ExitSpan + deriving (Show) + diff --git a/src/Instana/SDK/Internal/Config.hs b/src/Instana/SDK/Internal/Config.hs new file mode 100644 --- /dev/null +++ b/src/Instana/SDK/Internal/Config.hs @@ -0,0 +1,214 @@ +{-# LANGUAGE DeriveGeneric #-} +{-| +Module : Instana.SDK.Internal.Config +Description : Internal representation of the configuration. + +This internal module is not supposed to be used by client code. It's API can +change between releases, no guarantee for any kind of compatibility between +releases exists for this module. +-} +module Instana.SDK.Internal.Config + ( FinalConfig(..) + , mergeConfigs + , mkFinalConfig + , readConfigFromEnvironment + , readConfigFromEnvironmentAndApplyDefaults + ) where + + +import Control.Applicative ((<|>)) +import Data.Maybe (fromMaybe) +import GHC.Generics +import System.Environment (lookupEnv) +import Text.Read (readMaybe) + +import Instana.SDK.Config (Config) +import qualified Instana.SDK.Config as Config + + +-- |Environment variable for the agent host +agentHostKey :: String +agentHostKey = "INSTANA_AGENT_HOST" + + +-- |Environment variable for the agent port +agentPortKey :: String +agentPortKey = "INSTANA_AGENT_PORT" + + +-- |Environment variable for the agent name (server header) +agentNameKey :: String +agentNameKey = "INSTANA_AGENT_NAME" + + +-- |Environment variable for the force-transmision-afeter setting +forceTransmissionAfterKey :: String +forceTransmissionAfterKey = "INSTANA_FORCE_TRANSMISSION_STARTING_AFTER" + + +-- |Environment variable for the force-transmision-at setting +forceTransmissionStartingAtKey :: String +forceTransmissionStartingAtKey = "INSTANA_FORCE_TRANSMISSION_STARTING_AT" + + +-- |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 agent name +defaultAgentName :: String +defaultAgentName = "Instana Agent" + + +-- |Default force-transmission-after setting +defaultForceTransmissionAfter :: Int +defaultForceTransmissionAfter = 1000 + + +-- |Default force-transmission-at setting +defaultForceTransmissionStartingAt :: Int +defaultForceTransmissionStartingAt = 500 + + +-- |Default max-buffered-spans setting +defaultMaxBufferedSpans :: Int +defaultMaxBufferedSpans = 1000 + + +-- |The config after evaluating and merging user provided config, environment +-- variables and default values. +data FinalConfig = FinalConfig + { agentHost :: String + , agentPort :: Int + , agentName :: String + , forceTransmissionAfter :: Int + , forceTransmissionStartingAt :: Int + , maxBufferedSpans :: Int + } deriving (Eq, Generic, Show) + + +-- |Creates the FinalConfig. +mkFinalConfig :: + String + -> Int + -> String + -> Int + -> Int + -> Int + -> FinalConfig +mkFinalConfig + agentHost_ + agentPort_ + agentName_ + forceTransmissionAfter_ + forceTransmissionStartingAt_ + maxBufferedSpans_ = + FinalConfig + { agentHost = agentHost_ + , agentPort = agentPort_ + , agentName = agentName_ + , forceTransmissionAfter = forceTransmissionAfter_ + , forceTransmissionStartingAt = forceTransmissionStartingAt_ + , maxBufferedSpans = maxBufferedSpans_ + } + + +-- |Reads all provided config related environment variables. +readConfigFromEnvironment :: IO Config +readConfigFromEnvironment = do + agentHostEnv <- lookupEnv agentHostKey + agentPortEnv <- lookupEnv agentPortKey + agentNameEnv <- lookupEnv agentNameKey + forceTransmissionAfterEnv <- lookupEnv forceTransmissionAfterKey + forceTransmissionStartingAtEnv <- lookupEnv forceTransmissionStartingAtKey + maxBufferedSpansEnv <- lookupEnv maxBufferedSpansKey + let + -- parse numeric config values via readMaybe to Int if they were set, + -- otherwise they remain Nothing + agentPortParsed = agentPortEnv >>= readMaybe + forceTransmissionAfterParsed = + forceTransmissionAfterEnv >>= readMaybe + forceTransmissionStartingAtParsed = + forceTransmissionStartingAtEnv >>= readMaybe + maxBufferedSpansParsed = maxBufferedSpansEnv >>= readMaybe + return $ + Config.defaultConfig + { Config.agentHost = agentHostEnv + , Config.agentPort = agentPortParsed + , Config.agentName = agentNameEnv + , Config.forceTransmissionAfter = forceTransmissionAfterParsed + , Config.forceTransmissionStartingAt = forceTransmissionStartingAtParsed + , Config.maxBufferedSpans = maxBufferedSpansParsed + } + + +-- |Reads all provided config related environment variables and applies default +-- values for absent settings. +readConfigFromEnvironmentAndApplyDefaults :: IO FinalConfig +readConfigFromEnvironmentAndApplyDefaults = do + configFromEnv <- readConfigFromEnvironment + return $ applyDefaults configFromEnv + + +-- |Merges the user provided config with default values. +applyDefaults :: Config -> FinalConfig +applyDefaults config = + FinalConfig + { agentHost = + fromMaybe defaultAgentHost (Config.agentHost config) + , agentPort = + fromMaybe defaultAgentPort (Config.agentPort config) + , agentName = + fromMaybe defaultAgentName (Config.agentName config) + , forceTransmissionAfter = + fromMaybe + defaultForceTransmissionAfter + (Config.forceTransmissionAfter config) + , forceTransmissionStartingAt = + fromMaybe + defaultForceTransmissionStartingAt + (Config.forceTransmissionStartingAt config) + , maxBufferedSpans = + fromMaybe + defaultMaxBufferedSpans + (Config.maxBufferedSpans config) + } + + +-- |Merges two configs into a FinalConfig. +mergeConfigs :: Config -> Config -> FinalConfig +mergeConfigs userConfig configFromEnv = + let + merged = userConfig + { Config.agentHost = + (Config.agentHost userConfig) <|> + (Config.agentHost configFromEnv) + , Config.agentPort = + (Config.agentPort userConfig) <|> + (Config.agentPort configFromEnv) + , Config.agentName = + (Config.agentName userConfig) <|> + (Config.agentName configFromEnv) + , Config.forceTransmissionAfter = + (Config.forceTransmissionAfter userConfig) <|> + (Config.forceTransmissionAfter configFromEnv) + , Config.forceTransmissionStartingAt = + (Config.forceTransmissionStartingAt userConfig) <|> + (Config.forceTransmissionStartingAt configFromEnv) + , Config.maxBufferedSpans = + (Config.maxBufferedSpans userConfig) <|> + (Config.maxBufferedSpans configFromEnv) + } + in + applyDefaults merged diff --git a/src/Instana/SDK/Internal/Context.hs b/src/Instana/SDK/Internal/Context.hs new file mode 100644 --- /dev/null +++ b/src/Instana/SDK/Internal/Context.hs @@ -0,0 +1,207 @@ +{-# LANGUAGE DeriveGeneric #-} +{-| +Module : Instana.SDK.Internal.Context +Description : The Instana context holds everything that the SDK needs in terms of state. +-} +module Instana.SDK.Internal.Context + ( AgentConnection(..) + , InternalContext(..) + , ConnectionState(..) + , isAgentConnectionEstablished + , mkAgentReadyState + , readAgentUuid + , readPid + , whenConnected + ) where + + +import Control.Concurrent (ThreadId) +import Control.Concurrent.STM (STM) +import qualified Control.Concurrent.STM as STM +import Data.Map.Strict (Map) +import Data.Sequence (Seq) +import Data.Text (Text) +import qualified Foreign.C.Types as CTypes +import GHC.Generics +import Network.HTTP.Client as HttpClient +import qualified System.Metrics as Metrics + +import Instana.SDK.Internal.AgentConnection.Json.AnnounceResponse (AnnounceResponse) +import qualified Instana.SDK.Internal.AgentConnection.Json.AnnounceResponse as AnnounceResponse +import Instana.SDK.Internal.Command (Command) +import Instana.SDK.Internal.Config (FinalConfig) +import Instana.SDK.Internal.FullSpan (FullSpan) +import Instana.SDK.Internal.Metrics.Sample (TimedSample) +import Instana.SDK.Internal.SpanStack (SpanStack) + + +-- |The current state of the connection to the agent. +data ConnectionState = + -- |Connection handshake has not been started yet. + Unconnected + -- |Phase agent host lookup has been initiated. + | AgentHostLookup + -- |Agent host lookup is complete, the process has not been announced yet. + | Unannounced (String, Int) + -- |Announce was successful, waiting for the agent to signal readyness. + | Announced (String, Int) + -- |Agent has signaled that it is ready to accept data. + | AgentReady Ready + deriving (Eq, Show, Generic) + + +-- |Data to hold after agent ready event. +data Ready = + Ready + { connection :: AgentConnection + , metrics :: Metrics.Store + } deriving (Generic) + + +instance Eq Ready where + r1 == r2 = + connection r1 == connection r2 + + +instance Show Ready where + show r = + show $ connection r + + +-- |Meta data about the connection to the agent. +data AgentConnection = + AgentConnection + { + -- |the host of the agent we are connected to + agentHost :: String + -- |the port of the agent we are connected to + , agentPort :: Int + -- |the PID of the monitored process + , pid :: String + -- |the agent's UUID + , agentUuid :: Text + } + deriving (Eq, Show, Generic) + + +-- |Creates a "ready" connection state from an AnnounceResponse. +mkAgentReadyState :: + (String, Int) + -> AnnounceResponse + -> Metrics.Store + -> ConnectionState +mkAgentReadyState (host_, port_) announceResponse metricsStore = + let + agentConnection = AgentConnection + { agentHost = host_ + , agentPort = port_ + , pid = show $ AnnounceResponse.pid announceResponse + , agentUuid = AnnounceResponse.agentUuid announceResponse + } + in + AgentReady $ + Ready + { connection = agentConnection + , metrics = metricsStore + } + + +{-| A container for all the things the Instana SDK needs to do its work. +-} +data InternalContext = InternalContext + { config :: FinalConfig + , sdkStartTime :: Int + , httpManager :: HttpClient.Manager + , commandQueue :: STM.TQueue Command + , spanQueue :: STM.TVar (Seq FullSpan) + , connectionState :: STM.TVar ConnectionState + , fileDescriptor :: STM.TVar (Maybe CTypes.CInt) + , currentSpans :: STM.TVar (Map ThreadId SpanStack) + , previousMetricsSample :: STM.TVar TimedSample + } + + +instance Show InternalContext where + -- hide everything except for config when serializing context to string + show context = show (config context) + + +isAgentConnectionEstablishedSTM :: InternalContext -> STM Bool +isAgentConnectionEstablishedSTM context = do + state <- STM.readTVar $ connectionState context + return $ + case state of + AgentReady _ -> True + _ -> False + + +-- |Checks if the connection to the agent has been established. +isAgentConnectionEstablished :: InternalContext -> IO Bool +isAgentConnectionEstablished context = + STM.atomically $ isAgentConnectionEstablishedSTM context + + +readAgentUuidSTM :: InternalContext -> STM (Maybe Text) +readAgentUuidSTM context = do + state <- STM.readTVar $ connectionState context + return $ mapConnectionState agentUuid state + + +-- |accessor for the agent UUID +readAgentUuid :: InternalContext -> IO (Maybe Text) +readAgentUuid context = + STM.atomically $ readAgentUuidSTM context + + +readPidSTM :: InternalContext -> STM (Maybe String) +readPidSTM context = do + state <- STM.readTVar $ connectionState context + return $ mapConnectionState pid state + + +-- |accessor for the PID of the monitored process +readPid :: InternalContext -> IO (Maybe String) +readPid context = + STM.atomically $ readPidSTM context + + +mapConnectionState :: (AgentConnection -> a) -> ConnectionState -> Maybe a +mapConnectionState fn state = + case state of + AgentReady (Ready agentConnection _) -> + Just $ fn agentConnection + _ -> + Nothing + + +-- |Executes an IO action only when the connection to the agent has been +-- established. The action receives the agent host/port, PID, the agent UUID and +-- the internal metrics store as parameters (basically everything that is only +-- available with an established agent connection). +whenConnected :: + InternalContext + -> (AgentConnection -> Metrics.Store -> IO ()) + -> IO () +whenConnected context action = do + state <- STM.atomically $ STM.readTVar $ connectionState context + whenConnectedState + state + (\(Ready agentConnection metricsStore) -> + action agentConnection metricsStore + ) + + +whenConnectedState :: ConnectionState -> (Ready -> IO ()) -> IO () +whenConnectedState state action = do + case state of + Unconnected -> + return () + AgentHostLookup -> + return () + Unannounced _ -> + return () + Announced _ -> + return () + AgentReady ready -> do + action ready + diff --git a/src/Instana/SDK/Internal/FullSpan.hs b/src/Instana/SDK/Internal/FullSpan.hs new file mode 100644 --- /dev/null +++ b/src/Instana/SDK/Internal/FullSpan.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE OverloadedStrings #-} +{-| +Module : Instana.SDK.Internal.Context +Description : An internal representation of a span with all values set +-} +module Instana.SDK.Internal.FullSpan + ( FullSpan(..) + , FullSpanWithPid(..) + , SpanKind(..) + ) where + + +import Data.Aeson (FromJSON, ToJSON, Value, (.:), (.=)) +import qualified Data.Aeson as Aeson +import Data.Aeson.Types (Parser) +import Data.Text (Text) +import GHC.Generics + +import Instana.SDK.Internal.Id (Id) + + +-- |Direction of the call. +data SpanKind = + -- |The monitored componenent receives a call. + Entry + -- |The monitored componenent calls something else. + | Exit + -- |An additional annotation that is added to the trace while a traced call + -- is being processed. + | Intermediate + deriving (Eq, Generic, Show) + + +instance FromJSON SpanKind where + parseJSON :: Value -> Parser SpanKind + parseJSON = Aeson.withScientific "span kind string" $ + \k -> + case k of + -- (1=entry, 2=exit, 3=local/intermediate) + 1 -> return Entry + 2 -> return Exit + 3 -> return Intermediate + _ -> + fail "expected numeric span kind (1, 2, or 3)." + + +instance ToJSON SpanKind where + toJSON :: SpanKind -> Value + toJSON k = + case k of + Entry -> Aeson.Number 1 + Exit -> Aeson.Number 2 + Intermediate -> Aeson.Number 3 + + +-- |The `from` part of the span. +data From = From + { entityId :: String + } deriving (Eq, Generic, Show) + + +instance FromJSON From where + parseJSON = Aeson.withObject "from" $ + \f -> + From + <$> f .: "e" -- entityId + + +instance ToJSON From where + toJSON :: From -> Value + toJSON f = Aeson.object + [ "e" .= entityId f ] + + +-- |A representation of the span with all its data. This will be send to the +-- agent later. +data FullSpan = FullSpan + { traceId :: Id + , spanId :: Id + , parentId :: Maybe Id + , spanName :: Text + , timestamp :: Int + , duration :: Int + , kind :: SpanKind + , errorCount :: Int + , spanData :: Value + } deriving (Eq, Generic, Show) + + +-- |Combines the actual span data with static per-process data (PID). +data FullSpanWithPid = FullSpanWithPid + { fullSpan :: FullSpan + , pid :: String + } deriving (Eq, Generic, Show) + + +-- Compare +-- https://github.com/instana/technical-documentation/blob/master/tracing/format.md +-- Registered and SDK spans use the same format, exact same attributes. The only +-- difference is the data, SDK spans should provide data.sdk (see below). +instance ToJSON FullSpanWithPid where + toJSON :: FullSpanWithPid -> Value + toJSON fullSpanWithPid = + let + s = fullSpan fullSpanWithPid + p = pid fullSpanWithPid + in + Aeson.object + [ "t" .= traceId s + , "s" .= spanId s + , "p" .= parentId s + , "n" .= spanName s + , "ts" .= timestamp s + , "ta" .= ("haskell" :: String) + , "d" .= duration s + , "k" .= kind s + , "ec" .= errorCount s + , "data" .= spanData s + , "f" .= From p + -- TODO - missing attributes: + -- * data.service - should have dedicated functionality to be set (for SDK + -- spans) + -- * For SDK spans: Everything should be in data.sdk, structure is described in + -- https://github.com/instana/technical-documentation/blob/master/tracing/format.md#json-format-for-sdk-spans + -- * e: [{ # events that happened during this span, seems to be used mostly by EUM?? + -- t: # timestamp of this event relative to start (0 .. d) + -- v: # type of this annotation (ttfb, dom-ready, etc) + -- }], + -- * f.h: AgentId/HostID (optional), specified in the language announce response body. + -- }, + -- * b: { # batching data + -- s: # size; amount of batched spans + -- d: # duration in ms; more realistic time of time consumed by individual batched spans. (optional, regular duration taken if absent) + -- }, + -- * stack: [{ # stack trace + -- c: # Class name + -- m: # Method name + -- n: # Line number + -- f: # File name (optional in Java) + -- }], + -- * deferred: # whether the span is deferred (optional), ?? + ] + diff --git a/src/Instana/SDK/Internal/Id.hs b/src/Instana/SDK/Internal/Id.hs new file mode 100644 --- /dev/null +++ b/src/Instana/SDK/Internal/Id.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-| +Module : Instana.SDK.Internal.Id +Description : A module for working with trace IDs and span IDs +-} +module Instana.SDK.Internal.Id + ( Id + , generate + , fromString + , toByteString + , toText + -- exposed for testing purposes + , createFromIntsForTest + ) + 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 Data.List (foldl) +import Data.Text (Text) +import qualified Data.Text as T +import GHC.Generics +import Numeric (showHex) +import qualified System.Random as Random + + +-- |Represents an ID (trace ID, span ID). +data Id = + -- |a representation of a 64 bit ID with just enough Int components to + -- reach 64 bits (used when generating new random IDs) + IntComponents [Int] + -- |a representation of a 64 bit ID as a plain string (used when + -- deserializing IDs, for example when reading HTTP headers) + | IdString String + deriving (Eq, Generic, Show) + + +instance FromJSON Id where + parseJSON :: Value -> Parser Id + parseJSON = Aeson.withText "Id string" $ + \string -> return $ IdString $ (T.unpack string) + + +instance ToJSON Id where + toJSON :: Id -> Value + toJSON = + Aeson.String . toText + + +appendAsHex :: Int -> String -> Int -> String +appendAsHex noOfComponents accumulator intValue = + appendPaddedHex accumulator intValue + where + toHex = (flip showHex) "" . abs + padding = 64 `div` noOfComponents `div` 4 + toPaddedHex = leftPad padding . toHex + 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 + -- The number of bits used for an Haskell Int depends on the GHC + -- implementation. It is guaranteed to cover the range from -2^29 to 2^29 - 1. + -- On modern systems it is often -2^63 to 2^63 - 1. + -- + -- We need 64 bits, so we actually need to generate multiple Ints (usually + -- two) and stitch them together during JSON decoding. + let + requiredNumberOfIntComponents = 64 `div` bitsPerInt + (randomInts :: [Int]) <- + replicateM requiredNumberOfIntComponents Random.randomIO + return $ IntComponents $ randomInts + + +bitsPerInt :: Int +bitsPerInt = + floor $ logBase (2 :: Double) $ fromIntegral (maxBound :: Int) + + +-- |Converts a string into an ID. +fromString :: String -> Id +fromString = IdString + + +-- |Converts an ID into a String +toString :: Id -> String +toString theId = + case theId of + IntComponents intComponents -> + let + noOfComponents = length intComponents + in + foldl + (appendAsHex noOfComponents) + "" + (reverse intComponents) + IdString string -> + string + + +-- |Converts an ID into a Text +toText :: Id -> Text +toText = + T.pack . toString + + +-- |Converts an ID into a ByteString +toByteString :: Id -> BSC8.ByteString +toByteString = + BSC8.pack . toString + + +-- |Only exposed for testing, do not use this. +createFromIntsForTest :: [Int] -> Id +createFromIntsForTest = IntComponents + diff --git a/src/Instana/SDK/Internal/Logging.hs b/src/Instana/SDK/Internal/Logging.hs new file mode 100644 --- /dev/null +++ b/src/Instana/SDK/Internal/Logging.hs @@ -0,0 +1,213 @@ +{-| +Module : Instana.SDK.Internal.Logging +Description : Handles logging +-} +module Instana.SDK.Internal.Logging + ( initLogger + , instanaLogger + + -- exposed for testing + , parseLogLevel + -- exposed for testing + , minimumLogLevel + ) + where + + +import Control.Monad (when) +import Data.Maybe (catMaybes, isJust) +import Data.Traversable (sequence) +import System.Directory (getTemporaryDirectory) +import System.Environment (lookupEnv) +import System.IO (Handle, stdout) +import System.Log.Formatter +import System.Log.Handler (setFormatter) +import System.Log.Handler.Simple (GenericHandler, fileHandler, + streamHandler) +import System.Log.Logger (Priority (..), rootLoggerName, + setHandlers, setLevel, + updateGlobalLogger) + + +{-| Minimum Log level for messages written to the Instana Haskell SDK log file. +If not set, or set to an invalid log level, no log file will be created. If set +to a valid level, a log file named "instana-haskell-sdk.${pid}.log" will be +created in the system temp directory. + +If neither this nor INSTANA_LOG_LEVEL_STDOUT are set, the Instana Haskell SDK +will not emit any log messages at all. +-} +logLevelKey :: String +logLevelKey = "INSTANA_LOG_LEVEL" + + +{-| Minimum Log level for messages written to stdout. This option should only be +used during development. If not set, or set to an invalid log level, no log +messages will be written to stdout. + +If neither this nor INSTANA_LOG_LEVEL are set, the Instana Haskell SDK +will not emit any log messages at all. +-} +logLevelStdOutKey :: String +logLevelStdOutKey = "INSTANA_LOG_LEVEL_STDOUT" + + +{-| If neither this nor INSTANA_LOG_LEVEL are set, this setting is irrelevant +and will be ignored. + +Otherwise, if this is set to a non-empty string, a stdout logging handler will +be attached to the root logger instead of the Instana Haskell SDK logger, i. e.: + + updateGlobalLogger rootLoggerName $ setHandlers instanaStdOutHandler + +will be called. When INSTANA_LOG_LEVEL_STDOUT is also set, that log level will +be used, otherwise the highest log level (EMERGENCY) will be used for the +handler. + +This setting should be used if no other part of the running process (for example +the app which uses the Instana Haskell SDK) has already configured hslogger. In +particular, if this has not been set, the assumption is that "someone else" will +execute something like this with the root logger: + + updateGlobalLogger rootLoggerName $ setHandlers [ ..., appStdOutHandler, ... ] + +This is is necessary to avoid emitting all Instana log messages to stdout or to +avoid duplicating log messages on stdout in case INSTANA_LOG_LEVEL_STDOUT is +set. +See https://stackoverflow.com/a/40995265 +-} +overrideHsloggerRootHandlerKey :: String +overrideHsloggerRootHandlerKey = "INSTANA_OVERRIDE_HSLOGGER_ROOT_HANDLER" + + +-- |The SDK's logger name. +instanaLogger :: String +instanaLogger = "Instana" + + +-- |Initializes the SDK's logging. +initLogger :: String -> IO () +initLogger pid = do + logLevelFileStr <- lookupEnv logLevelKey + logLevelStdOutStr <- lookupEnv logLevelStdOutKey + let + logLevelFile = logLevelFileStr >>= parseLogLevel + logLevelStdOut = logLevelStdOutStr >>= parseLogLevel + + let + minLogLevel = minimumLogLevel logLevelFile logLevelStdOut + + case minLogLevel of + Just minLevel -> + actuallyInitLogger pid minLevel logLevelFile logLevelStdOut + Nothing -> do + return () + + +actuallyInitLogger :: + String -> + Priority -> + Maybe Priority -> + Maybe Priority -> + IO () +actuallyInitLogger pid minLogLevel logLevelFile logLevelStdOut = do + updateGlobalLogger instanaLogger $ setLevel minLogLevel + logFileHandler <- + sequence $ + (\logLevel -> createFileHandler pid logLevel) <$> logLevelFile + stdOutHandler <- + sequence $ + (\logLevel -> createStdOutHandler logLevel) <$> logLevelStdOut + setLogHandlers logFileHandler stdOutHandler + + +createFileHandler :: String -> Priority -> IO (GenericHandler Handle) +createFileHandler pid logLevel = do + systemTempDir <- getTemporaryDirectory + let + systemTempDir' = + case last systemTempDir of + '/' -> systemTempDir + '\\' -> systemTempDir + _ -> systemTempDir ++ "/" + logPath = systemTempDir' ++ "instana-haskell-sdk." ++ pid ++ ".log" + instanaFileHandler <- fileHandler logPath logLevel + let + formattedInstanaFileHandler = withFormatter instanaFileHandler + return formattedInstanaFileHandler + + +createStdOutHandler :: Priority -> IO (GenericHandler Handle) +createStdOutHandler logLevel = do + instanaStreamHandler <- streamHandler stdout logLevel + let + formattedInstanaStreamHandler = withFormatter instanaStreamHandler + return formattedInstanaStreamHandler + + +setLogHandlers :: + Maybe (GenericHandler Handle) + -> Maybe (GenericHandler Handle) + -> IO () +setLogHandlers logFileHandler stdOutHandler = do + overrideHsloggerRootHandlerVal <- + lookupEnv overrideHsloggerRootHandlerKey + let + overrideHsloggerRootHandler = + isJust overrideHsloggerRootHandlerVal + + handlers = + catMaybes + [ logFileHandler + , if overrideHsloggerRootHandler + then Nothing + else stdOutHandler + ] + + updateGlobalLogger instanaLogger $ setHandlers handlers + + -- override stdout handler on root logger level if requested + when overrideHsloggerRootHandler + (do + actualStdOutHandler <- + case stdOutHandler of + Just handler -> + return handler + Nothing -> + createStdOutHandler EMERGENCY + let + overrideRootHhandlers = [ actualStdOutHandler ] + updateGlobalLogger rootLoggerName $ setHandlers overrideRootHhandlers + ) + + +withFormatter :: GenericHandler Handle -> GenericHandler Handle +withFormatter handler = setFormatter handler formatter + -- http://hackage.haskell.org/packages/archive/hslogger/1.1.4/doc/html/System-Log-Formatter.html + where + timeFormat = "%F %H:%M:%S.%4q %z" + formatter = tfLogFormatter timeFormat "[$time $loggername $pid $prio] $msg" + + +-- |Parses a string into a hslogger log level. +parseLogLevel :: String -> Maybe Priority +parseLogLevel logLevelStr = + case logLevelStr of + "DEBUG" -> Just DEBUG + "INFO" -> Just INFO + "NOTICE" -> Just NOTICE + "WARNING" -> Just WARNING + "ERROR" -> Just ERROR + "CRITICAL" -> Just CRITICAL + "ALERT" -> Just ALERT + "EMERGENCY" -> Just EMERGENCY + _ -> Nothing + + +-- |Calculates the minimum of two log levels. +minimumLogLevel :: Maybe Priority -> Maybe Priority -> Maybe Priority +minimumLogLevel (Just l1) (Just l2) = Just $ min l1 l2 +minimumLogLevel (Just l) Nothing = Just l +minimumLogLevel Nothing (Just l) = Just l +minimumLogLevel _ _ = Nothing + diff --git a/src/Instana/SDK/Internal/Metrics/Collector.hs b/src/Instana/SDK/Internal/Metrics/Collector.hs new file mode 100644 --- /dev/null +++ b/src/Instana/SDK/Internal/Metrics/Collector.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE OverloadedStrings #-} +{-| +Module : Instana.SDK.Internal.Metrics.Collector +Description : Initializes the collection of metrics and samples them at + regular intervals. +-} +module Instana.SDK.Internal.Metrics.Collector + ( registerMetrics + , sampleAll + ) where + + +import qualified Data.List as List +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock.POSIX (getPOSIXTime) +import qualified Data.Version as Version +import Paths_instana_haskell_trace_sdk (version) +import qualified System.Metrics as Metrics +import qualified System.SysInfo as SysInfo + +import Instana.SDK.Internal.AgentConnection.ProcessInfo (ProcessInfo) +import qualified Instana.SDK.Internal.AgentConnection.ProcessInfo as ProcessInfo +import Instana.SDK.Internal.Util ((|>)) + + +registerMetrics :: String -> ProcessInfo -> Int -> IO Metrics.Store +registerMetrics translatedPid processInfo sdkStartTime = do + -- registerMetrics is executed once more after each connection loss/reconnect. + -- It should not be an actual problem, as the previous metrics store should + -- have been garbage collected. + + instanaMetricsStore <- Metrics.newStore + + -- register Instana specific metrics (mostly snapshot data) + registerCustomMetrics + instanaMetricsStore + translatedPid + processInfo + sdkStartTime + + -- register all predefined GC metrics provided by ekg + Metrics.registerGcMetrics instanaMetricsStore + return instanaMetricsStore + + +sampleAll :: Metrics.Store -> IO Metrics.Sample +sampleAll = Metrics.sampleAll + + +registerCustomMetrics :: + Metrics.Store + -> String + -> ProcessInfo + -> Int + -> IO () +registerCustomMetrics + instanaMetricsStore + translatedPid + processInfo + sdkStartTime = do + startTime <- calcStartTime sdkStartTime + registerConstantLabelMetric + instanaMetricsStore + "pid" + translatedPid + registerConstantLabelMetric + instanaMetricsStore + "programName" + (ProcessInfo.programName processInfo) + registerConstantLabelMetric + instanaMetricsStore + "executablePath" + (ProcessInfo.executablePath processInfo) + registerConstantLabelMetric + instanaMetricsStore + "arguments" + (ProcessInfo.arguments processInfo |> List.intercalate " ") + registerConstantLabelMetric + instanaMetricsStore + "sensorVersion" + (Version.showVersion version) + registerConstantCounterMetric + instanaMetricsStore + "startTime" + startTime + + +calcStartTime :: Int -> IO Int +calcStartTime sdkStartTime = do + sysInfoOrError <- SysInfo.sysInfo + now <- round . (* 1000) <$> getPOSIXTime + case sysInfoOrError of + Right sysInfo -> do + return $ now - (fromIntegral $ SysInfo.uptime sysInfo) + Left _ -> + -- System.SysInfo is not available on non-Linux systems, we use the time + -- when the SDK has been initialized as a fallback. + return sdkStartTime + + +registerConstantLabelMetric :: Metrics.Store -> Text -> String -> IO () +registerConstantLabelMetric instanaMetricsStore label value = do + Metrics.registerLabel label (return $ T.pack value) instanaMetricsStore + + +registerConstantCounterMetric :: Metrics.Store -> Text -> Int -> IO () +registerConstantCounterMetric instanaMetricsStore label value = do + Metrics.registerCounter + label + (return $ fromIntegral value) + instanaMetricsStore + diff --git a/src/Instana/SDK/Internal/Metrics/Compression.hs b/src/Instana/SDK/Internal/Metrics/Compression.hs new file mode 100644 --- /dev/null +++ b/src/Instana/SDK/Internal/Metrics/Compression.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE OverloadedStrings #-} +{-| +Module : Instana.SDK.Internal.Metrics.Compression +Description : Removes unchanged metrics from the sampled metrics to save + bandwidth/CPU (JSON seralization/deserialization). +-} +module Instana.SDK.Internal.Metrics.Compression + ( compressSample + ) where + + +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import qualified Data.List as List +import Data.Text (Text) + +import Instana.SDK.Internal.Metrics.Deltas (deltaKeyList) +import Instana.SDK.Internal.Metrics.Sample (InstanaMetricValue (IntegralValue), + InstanaSample) + + +dummyMapWithKeysEligibleForDeltaComputation :: HashMap Text InstanaMetricValue +dummyMapWithKeysEligibleForDeltaComputation = + List.foldl + (\dummyMap key -> HashMap.insert key dummyValue dummyMap) + HashMap.empty + deltaKeyList + where + dummyValue = IntegralValue 0 + + +compressSample :: InstanaSample -> InstanaSample -> InstanaSample +compressSample previous next = + let + -- step 1: remove the original metrics from which we have computed deltas, + -- those are not used in the back end (we are only interested in the delta + -- values of those metrics) + deltaSourcesRemoved = + HashMap.difference + next + dummyMapWithKeysEligibleForDeltaComputation + in + -- step 2: remove all values for which the value has not changed since the + -- last sent metric payload + HashMap.differenceWith dropUnchanged deltaSourcesRemoved previous + + +dropUnchanged :: + InstanaMetricValue + -> InstanaMetricValue + -> Maybe InstanaMetricValue +dropUnchanged nextValue previousValue = + if nextValue == previousValue then + Nothing + else + Just nextValue + diff --git a/src/Instana/SDK/Internal/Metrics/Deltas.hs b/src/Instana/SDK/Internal/Metrics/Deltas.hs new file mode 100644 --- /dev/null +++ b/src/Instana/SDK/Internal/Metrics/Deltas.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE OverloadedStrings #-} +{-| +Module : Instana.SDK.Internal.Metrics.Delta +Description : Computes deltas between two metrics samples. +-} +module Instana.SDK.Internal.Metrics.Deltas + ( deltaKeyList + , enrichWithDeltas + ) where + + +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import Data.Text (Text) +import qualified Data.Text as T + +import Instana.SDK.Internal.Metrics.Sample (InstanaMetricValue, + TimedSample) +import qualified Instana.SDK.Internal.Metrics.Sample as Sample + + +deltaKeyList :: [Text] +deltaKeyList = + [ "rts.gc.bytes_allocated" + , "rts.gc.num_gcs" + , "rts.gc.num_bytes_usage_samples" + , "rts.gc.cumulative_bytes_used" + , "rts.gc.bytes_copied" + , "rts.gc.init_cpu_ms" + , "rts.gc.init_wall_ms" + , "rts.gc.mutator_cpu_ms" + , "rts.gc.mutator_wall_ms" + , "rts.gc.gc_cpu_ms" + , "rts.gc.gc_wall_ms" + , "rts.gc.cpu_ms" + , "rts.gc.wall_ms" + ] + + +enrichWithDeltas :: TimedSample -> TimedSample -> TimedSample +enrichWithDeltas previousSample currentSample = + let + currentTimestamp = Sample.timestamp currentSample + previousTimestamp = Sample.timestamp previousSample + deltaT = currentTimestamp - previousTimestamp + + previousMetrics = Sample.sample previousSample + currentMetrics = Sample.sample currentSample + + metricsWithDeltas = + HashMap.foldrWithKey + (addDeltaToSample deltaT previousMetrics) + currentMetrics + currentMetrics + in + Sample.mkTimedSample metricsWithDeltas currentTimestamp + + +addDeltaToSample :: + Int + -> HashMap Text InstanaMetricValue + -> Text + -> InstanaMetricValue + -> HashMap Text InstanaMetricValue + -> HashMap Text InstanaMetricValue +addDeltaToSample deltaT previousMetrics metricKey currentMetricValue currentMetrics = + if not (elem metricKey deltaKeyList) then + currentMetrics + else + let + previousMetricValue = HashMap.lookup metricKey previousMetrics + in + case (previousMetricValue, currentMetricValue) of + -- We are only interested in integer metrics here. Reason: The ekg package + -- only emits integer values and only the deltas are fractional values. We + -- never want to compute a delta of two deltas, that wouldn't make sense. + (Just (Sample.IntegralValue previousValue), + Sample.IntegralValue currentValue) -> + addNormalizedDelta + metricKey + deltaT + (currentValue - previousValue) + currentMetrics + -- The metric is present in the current sample but was not present in the + -- previous sample, that must be the first sample taken ever. Assume zero + -- for the previous value. + (Nothing, Sample.IntegralValue currentValue) -> + addNormalizedDelta + metricKey + deltaT + currentValue + currentMetrics + _ -> + currentMetrics + + +addNormalizedDelta :: + Text + -> Int + -> Int + -> HashMap Text InstanaMetricValue + -> HashMap Text InstanaMetricValue +addNormalizedDelta metricKey deltaT deltaV metrics = + let + deltaKey = T.append metricKey "_delta" + -- Normalize difference to a one second timespan, no matter how much time + -- elapsed between taking the two samples. The provided timestamps (and thus + -- deltaT) are in milliseconds. + normalizedDeltaV = + Sample.FractionalValue $ + (fromIntegral deltaV / fromIntegral deltaT) * 1000 + in + HashMap.insert + deltaKey + normalizedDeltaV + metrics + diff --git a/src/Instana/SDK/Internal/Metrics/Sample.hs b/src/Instana/SDK/Internal/Metrics/Sample.hs new file mode 100644 --- /dev/null +++ b/src/Instana/SDK/Internal/Metrics/Sample.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-| +Module : Instana.SDK.Internal.Metrics.Sample +Description : Instana's internal representation of metrics values and samples. +-} +module Instana.SDK.Internal.Metrics.Sample + ( InstanaSample + , InstanaMetricValue(..) + , SampleJson(..) + , TimedSample(..) + , ValueJson(..) + , ekgSampleToInstanaSample + , ekgValueToInstanaValue + , empty + , encodeSample + , encodeValue + , isMarkedForReset + , markForReset + , mkTimedSample + , timedSampleFromEkgSample + ) where + + +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Types as A +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import Data.Text (Text) +import qualified Data.Text as T +import GHC.Generics +import qualified System.Metrics as Metrics + + +type InstanaSample = HashMap Text InstanaMetricValue + + +data InstanaMetricValue = + StringValue Text + | IntegralValue Int + | FractionalValue Double + deriving (Eq, Generic, Show) + + +-- instance A.ToJSON InstanaMetricValue where +-- toJSON = encodeValue + + +ekgSampleToInstanaSample :: Metrics.Sample -> InstanaSample +ekgSampleToInstanaSample = + HashMap.map ekgValueToInstanaValue + + +ekgValueToInstanaValue :: Metrics.Value -> InstanaMetricValue +ekgValueToInstanaValue ekgValue = + case ekgValue of + Metrics.Label text -> StringValue text + Metrics.Counter int64 -> IntegralValue (fromIntegral int64) + Metrics.Gauge int64 -> IntegralValue (fromIntegral int64) + Metrics.Distribution _ -> StringValue "distribution" + + +-- |A metrics sample with timestamp +data TimedSample = + TimedSample + { + -- |The metrics sample + sample :: InstanaSample + -- |The timestamp + , timestamp :: Int + , resetNext :: Bool + } deriving (Eq, Generic, Show) + + +empty :: Int -> TimedSample +empty t = + TimedSample { + sample = HashMap.empty + , timestamp = t + , resetNext = False + } + + +mkTimedSample :: InstanaSample -> Int -> TimedSample +mkTimedSample sampledMetrics t = + TimedSample { + sample = sampledMetrics + , timestamp = t + , resetNext = False + } + + +timedSampleFromEkgSample :: Metrics.Sample -> Int -> TimedSample +timedSampleFromEkgSample sampledMetrics = + mkTimedSample (ekgSampleToInstanaSample sampledMetrics) + + +markForReset :: TimedSample -> TimedSample +markForReset timedSample = + timedSample { resetNext = True } + + +isMarkedForReset :: TimedSample -> Bool +isMarkedForReset = resetNext + + +encodeSample :: InstanaSample -> A.Value +encodeSample metrics = + buildOne metrics $ A.emptyObject + where + buildOne :: HashMap T.Text InstanaMetricValue -> A.Value -> A.Value + buildOne m o = HashMap.foldlWithKey' build o m + + build :: A.Value -> T.Text -> InstanaMetricValue -> A.Value + build m name val = go m (T.splitOn "." name) val + + go :: A.Value -> [T.Text] -> InstanaMetricValue -> A.Value + go (A.Object m) [str] val = A.Object $ HashMap.insert str metric m + where metric = encodeValue val + go (A.Object m) (str:rest) val = case HashMap.lookup str m of + Nothing -> A.Object $ HashMap.insert str (go A.emptyObject rest val) m + Just m' -> A.Object $ HashMap.insert str (go m' rest val) m + go v _ _ = typeMismatch "Object" v + +typeMismatch :: String -- ^ The expected type + -> A.Value -- ^ The actual value encountered + -> a +typeMismatch expected actual = + error $ "when expecting a " ++ expected ++ ", encountered " ++ name ++ + " instead" + where + name = case actual of + A.Object _ -> "Object" + A.Array _ -> "Array" + A.String _ -> "String" + A.Number _ -> "Number" + A.Bool _ -> "Boolean" + A.Null -> "Null" + + +-- | Encodes a single metric value to JSON +encodeValue :: InstanaMetricValue -> A.Value +encodeValue (IntegralValue n) = Aeson.toJSON n +encodeValue (FractionalValue f) = Aeson.toJSON f +encodeValue (StringValue s) = Aeson.toJSON s + + +newtype SampleJson = SampleJson InstanaSample + deriving Show + +instance A.ToJSON SampleJson where + toJSON (SampleJson s) = encodeSample s + +newtype ValueJson = ValueJson InstanaMetricValue + deriving Show + +instance A.ToJSON ValueJson where + toJSON (ValueJson v) = encodeValue v + diff --git a/src/Instana/SDK/Internal/Retry.hs b/src/Instana/SDK/Internal/Retry.hs new file mode 100644 --- /dev/null +++ b/src/Instana/SDK/Internal/Retry.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-| +Module : Instana.SDK.Internal.Retry +Description : Handles retrying IO actions that might fail (mostly HTTP requests) +-} +module Instana.SDK.Internal.Retry + ( acceptDataRetryPolicy + , agentHostLookupRetryPolicy + , announceRetryPolicy + , retryRequest + , retryUntil + , retryUntilRight + ) where + +import Control.Monad.Catch (Handler) +import qualified Control.Retry as Retry +import Data.ByteString.Lazy (ByteString) +import Data.Semigroup ((<>)) +import qualified Network.HTTP.Client as HTTP + + +{-| A fibonacci retry delay pattern starting with a 1 second delay going up +to 1 minute delay. This retry policy never gives up. +-} +agentHostLookupRetryPolicy :: Retry.RetryPolicyM IO +agentHostLookupRetryPolicy = + Retry.capDelay maxDelay $ + Retry.fibonacciBackoff minDelay + where + -- 1 second + minDelay = 1 * 1000 * 1000 + -- 60 seconds + maxDelay = 60 * 1000 * 1000 + + +{-| A constant delay pattern with a 200 ms second delay. This retry policy +gives up after 3 attempts. +-} +announceRetryPolicy :: Retry.RetryPolicyM IO +announceRetryPolicy = + (Retry.constantDelay delay) <> (Retry.limitRetries retries) + where + delay = 200 * 1000 + retries = 3 + + +{-| A constant delay pattern with a 10 second delay. This retry policy +gives up after 10 attempts. +-} +acceptDataRetryPolicy :: Retry.RetryPolicyM IO +acceptDataRetryPolicy = + (Retry.constantDelay delay) <> (Retry.limitRetries retries) + where + delay = 10 * 1000 * 1000 + retries = 10 + + +{-| Retries a given HTTP request according to the given retry policy, +until either the request succeeds or the retry policy mandates to stop retrying. +-} +retryRequest :: + Retry.RetryPolicyM IO + -> (HTTP.Response ByteString -> IO a) + -> IO (HTTP.Response ByteString) + -> IO a +retryRequest retryPolicy decoder request = + let + reportHttpError :: Bool -> HTTP.HttpException -> Retry.RetryStatus -> IO () + reportHttpError _ _ _ {- retriedOrCrashed err retryStatus -} = + return () + -- For a detailed error message, we could use Retry.defaultLogMsg, like + -- this: + -- traceM instanaLogger $ + -- Retry.defaultLogMsg retriedOrCrashed err retryStatus + -- But we generally do not want this level of verbosity here in retry, + -- instead, we are perfectly fine with swallowing the excetption + -- completely. + retryOnAnyHttpError :: HTTP.HttpException -> IO Bool + retryOnAnyHttpError _ = return True + retryOnAnyStatus :: Retry.RetryStatus -> Handler IO Bool + retryOnAnyStatus = Retry.logRetries retryOnAnyHttpError reportHttpError + + executeRequestAndParseResponse = do + response <- request + decoded <- decoder response + return decoded + + in + Retry.recovering + retryPolicy + [retryOnAnyStatus] + (const executeRequestAndParseResponse) + + +{-| Retries a given action according to the given retry policy, until it either +yields a result matching Right _ or until the retry policy mandates to stop +retrying, which ever happens first. +-} +retryUntilRight :: + forall a. + Show a => + Retry.RetryPolicyM IO + -> IO (Either String a) + -> IO (Either String a) +retryUntilRight retryPolicy action = + retryUntil retryPolicy (\_ -> True) action + + +{-| Retries a given action according to the given retry policy, until either the +given retry check function returns True or the retry policy mandates to stop +retrying. +-} +retryUntil :: + forall a. + Show a => + Retry.RetryPolicyM IO + -> (a -> Bool) + -> IO (Either String a) + -> IO (Either String a) +retryUntil retryPolicy retryCheck action = do + let + check :: Retry.RetryStatus -> Either String a -> IO Bool + check _ result = do + case result of + Left _ -> + return True + Right value -> + return $ not $ retryCheck value + lastResult <- Retry.retrying + retryPolicy + check + (const action) + case lastResult of + Left _ -> + return lastResult + Right lastValue -> + if retryCheck lastValue + then + return lastResult + else + return $ + Left $ + "The retried action has not yielded the expected result " ++ + "but: " ++ show lastValue + diff --git a/src/Instana/SDK/Internal/Secrets.hs b/src/Instana/SDK/Internal/Secrets.hs new file mode 100644 --- /dev/null +++ b/src/Instana/SDK/Internal/Secrets.hs @@ -0,0 +1,167 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE OverloadedStrings #-} +{-| +Module : Instana.SDK.Internal.Secrets +Description : Secrets scrubbing +-} +module Instana.SDK.Internal.Secrets + ( MatcherMode(..) + , SecretsMatcher(..) + , defaultSecretsMatcher + , isSecret + ) where + +import Data.Aeson (FromJSON, Value, (.:)) +import qualified Data.Aeson as Aeson +import Data.Aeson.Types (Parser) +import qualified Data.Either as Either +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 Text.Regex.Base.RegexLike as RegexBase +import qualified Text.Regex.TDFA as Regex +import Text.Regex.TDFA.String (Regex) +import qualified Text.Regex.TDFA.String as RegexString + +import Instana.SDK.Internal.Util ((|>)) + + +data MatcherMode = + Equals + | EqualsIgnoreCase + | Contains + | ContainsIgnoreCase + | Regex + | None + deriving (Eq, Show, Generic) + + +instance FromJSON MatcherMode where + parseJSON :: Value -> Parser MatcherMode + parseJSON = Aeson.withText "secrets matcher mode string" $ + \matcherModeText -> + case matcherModeText of + "equals-ignore-case" -> return EqualsIgnoreCase + "equals" -> return Equals + "contains-ignore-case" -> return ContainsIgnoreCase + "contains" -> return Contains + "regex" -> return Regex + "none" -> return None + _ -> + fail $ "unknown secrets matcher mode: " ++ (T.unpack matcherModeText) + + +data SecretsMatcher = + EqualsMatcher [Text] + | EqualsIgnoreCaseMatcher [Text] + | ContainsMatcher [Text] + | ContainsIgnoreCaseMatcher [Text] + | RegexMatcher [Regex] + | NoneMatcher + + +instance FromJSON SecretsMatcher where + parseJSON = Aeson.withObject "SecretsMatcher" $ parseSecretsConfig + + +instance Eq SecretsMatcher where + (==) :: SecretsMatcher -> SecretsMatcher -> Bool + s1 == s2 = + case (s1, s2) of + (RegexMatcher _, _) -> False + (_, RegexMatcher _) -> False + _ -> s1 == s2 + + +instance Show SecretsMatcher where + show :: SecretsMatcher -> String + show s = + case s of + RegexMatcher _ -> "RegexMatcher" + _ -> show s + + +parseSecretsConfig :: Aeson.Object -> Parser SecretsMatcher +parseSecretsConfig object = + (object .: "matcher") >>= + (\matcherMode -> + (object .: "list") >>= postProcessList matcherMode + ) + where + postProcessList :: MatcherMode -> [Text] -> Parser SecretsMatcher + postProcessList matcherMode secretsList = + case matcherMode of + Equals -> + return $ EqualsMatcher secretsList + EqualsIgnoreCase -> + return $ EqualsIgnoreCaseMatcher $ List.map T.toLower secretsList + Contains -> + return $ ContainsMatcher secretsList + ContainsIgnoreCase -> + return $ ContainsIgnoreCaseMatcher $ List.map T.toLower secretsList + Regex -> + return $ RegexMatcher $ + List.map preProcessRegexPattern secretsList + |> Either.rights + None -> + return $ NoneMatcher + + +defaultSecretsMatcher :: SecretsMatcher +defaultSecretsMatcher = + ContainsIgnoreCaseMatcher ["key", "pass", "secret"] + + +isSecret :: SecretsMatcher -> Text -> Bool +isSecret (EqualsMatcher secretsList) potentialSecret = + elem potentialSecret secretsList +isSecret (EqualsIgnoreCaseMatcher secretsList) potentialSecret = + elem (T.toLower potentialSecret) secretsList +isSecret (ContainsMatcher secretsList) potentialSecret = + List.find (flip T.isInfixOf potentialSecret) secretsList |> Maybe.isJust +isSecret (ContainsIgnoreCaseMatcher secretsList) potentialSecret = + let + potentialSecret' = T.toLower potentialSecret + in + List.find (flip T.isInfixOf potentialSecret') secretsList |> Maybe.isJust +isSecret (RegexMatcher patterns) potentialSecret = + let + potentialSecret' = T.unpack potentialSecret + in + List.find + (\pattern -> RegexBase.match pattern potentialSecret') patterns + |> Maybe.isJust +isSecret (NoneMatcher) _ = + False + + +preProcessRegexPattern :: Text -> Either String Regex +preProcessRegexPattern pattern = + -- The Java regex matcher only matches if the whole string is a match, + -- Haskell regexes RegExp.test matches if the regex is found as a substring. + -- To achieve parity with the Java functionality, we enclose the regex in + -- '^' and '$'. + pattern + |> prependCaret + |> appendDollar + |> T.unpack + |> RegexString.compile + Regex.defaultCompOpt + Regex.defaultExecOpt + +prependCaret :: Text -> Text +prependCaret t = + if T.null t then t + else if (T.head t == '^') then t + else T.cons '^' t + + +appendDollar :: Text -> Text +appendDollar t = + if T.null t then t + else if (T.last t == '$') then t + else T.snoc t '$' + diff --git a/src/Instana/SDK/Internal/SpanStack.hs b/src/Instana/SDK/Internal/SpanStack.hs new file mode 100644 --- /dev/null +++ b/src/Instana/SDK/Internal/SpanStack.hs @@ -0,0 +1,206 @@ +{-# LANGUAGE DeriveGeneric #-} +{-| +Module : Instana.SDK.Internal.SpanStack +Description : Keeps the current spans of a thread. +-} +module Instana.SDK.Internal.SpanStack + ( SpanStack + , empty + , entry + , isEmpty + , isSuppressed + , mapTop + , peek + , pop + , popWhenMatches + , push + , pushSuppress + , suppress + ) where + +-- Implementation Note +-- =================== +-- +-- This implementation currently heavily relies on the assumption that the +-- monitored application does not employ context switches in a thread (like +-- 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. +-- +-- 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 +-- to the last exit has completed. The same holds for any entry span. Thus, the +-- spans in one thread do not form a tree (as async contexts and their spans do +-- in Node.js for example) but only a stack with maximal depth 2, like this: +-- * no current span, currently not tracing +-- * an active entry span but not exit +-- * a non-active entry and an active exit + + +import GHC.Generics + +import Instana.SDK.Internal.Util ((|>)) +import Instana.SDK.Span.EntrySpan (EntrySpan) +import Instana.SDK.Span.ExitSpan (ExitSpan) +import Instana.SDK.Span.Span (Span (..), SpanKind (..)) + + +{-|The stack of currently open spans in one thread. +-} +data SpanStack = + -- |Indicates that we are currently not processing any request. + None + -- |Indicates that we are currently processing a request that had + -- X-INSTANA-L=0 set and that should not record any spans. + | Suppressed + -- |Indicates that we are currently processing an entry. + | EntryOnly EntrySpan + -- |Indicates that currently an exit is in progress. + | EntryAndExit EntrySpan ExitSpan + deriving (Eq, Generic, Show) + + +{-|Creates an empty span stack. +-} +empty :: SpanStack +empty = + None + + +{-|Initializes a span stack with one entry span. +-} +entry :: EntrySpan -> SpanStack +entry entrySpan = + empty + |> push (Entry entrySpan) + + +{-|Creates an span stack with a suppressed marker. +-} +suppress :: SpanStack +suppress = + Suppressed + + +{-|Checks if the span stack is empty. +-} +isEmpty :: SpanStack -> Bool +isEmpty t = + t == None + + +{-|Checks if tracing is currently suppressed. +-} +isSuppressed :: SpanStack -> Bool +isSuppressed t = + t == Suppressed + + +{-|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. +-} +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 = + EntryOnly entrySpan +push (Exit exitSpan) (EntryOnly entrySpan) = + EntryAndExit entrySpan exitSpan +-- ignore invalid calls/invalid state +push _ current = + current + + +{-|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. +-} +pushSuppress :: SpanStack -> SpanStack +pushSuppress None = + Suppressed +pushSuppress Suppressed = + Suppressed +-- ignore invalid calls/invalid state +pushSuppress current = + current + + +{-|Pops the top element, returns a tuple of the top element and the remaining +stack after poppint the top element. +-} +pop :: SpanStack -> (SpanStack, Maybe Span) +pop None = + (None, Nothing) +pop Suppressed = + (None, Nothing) +pop (EntryOnly entrySpan) = + (None, Just $ Entry entrySpan) +pop (EntryAndExit entrySpan exitSpan) = + (EntryOnly entrySpan, Just $ Exit exitSpan) + + +{-|Pops the top element, but only if the top element is of the expected kind. +If so, a tuple of the top element and the remaining stack after popping the top +element is returned. If not, Nothing and an unmodified stack is returned. The +last part of the 3-tuple is an error message that is only provided if there is +a mismatch between the expected span kind and the actual span kind on the top of +the stack. +-} +popWhenMatches :: SpanKind -> SpanStack -> (SpanStack, Maybe Span, Maybe String) +popWhenMatches _ None = + (None, Nothing, Nothing) +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 expectedKind stack = + case (expectedKind, peek stack) of + (EntryKind, Just (Entry _)) -> + (st, sp, Nothing) + where + (st, sp) = pop stack + (ExitKind, Just (Exit _)) -> + (st, sp, Nothing) + where + (st, sp) = pop stack + (_, actualTopElement) -> + ( stack + , Nothing + , Just $ "Cannot pop \"" ++ (show expectedKind) ++ + " from span stack. Current top element: " ++ show actualTopElement + ) + + +{-|Returns the top element without modifying the stack. +-} +peek :: SpanStack -> Maybe Span +peek None = + Nothing +peek Suppressed = + Nothing +peek (EntryOnly entrySpan) = + Just $ Entry entrySpan +peek (EntryAndExit _ exitSpan) = + Just $ Exit 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 fn stack = + let + (remainder, Just oldTop) = pop stack + newTop = fn oldTop + in + push newTop remainder + diff --git a/src/Instana/SDK/Internal/URL.hs b/src/Instana/SDK/Internal/URL.hs new file mode 100644 --- /dev/null +++ b/src/Instana/SDK/Internal/URL.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE DeriveGeneric #-} +{-| +Module : Instana.SDK.Internal.URL +Description : Representation of an URL +-} +module Instana.SDK.Internal.URL + ( URL + , mkHttp + , mkHttps + , mkUrl + ) where + + +import GHC.Generics + + +data Protocol = HTTP | HTTPS + deriving (Eq, Generic) + + +instance Show Protocol where + show HTTP = "http://" + show HTTPS = "https://" + + +-- |Represents a URL. +data URL = URL + { protocol :: Protocol + , host :: String + , port :: Int + , path :: String + } deriving (Eq, Generic) + + +instance Show URL where + show url = + (show $ protocol url) ++ + (host url) ++ ":" ++ + (show $ port url) ++ "/" ++ + (path url) + + +-- |Creates a URL. +mkUrl :: + Protocol + -> String + -> Int + -> String + -> URL +mkUrl _protocol _host _port _path = + URL + { protocol = _protocol + , host = _host + , port = _port + , path = _path + } + + +-- |Creates a HTTP URL. +mkHttp :: + String + -> Int + -> String + -> URL +mkHttp = mkUrl HTTP + + +-- |Creates a HTTPS URL. +mkHttps :: + String + -> Int + -> String + -> URL +mkHttps = mkUrl HTTPS + diff --git a/src/Instana/SDK/Internal/Util.hs b/src/Instana/SDK/Internal/Util.hs new file mode 100644 --- /dev/null +++ b/src/Instana/SDK/Internal/Util.hs @@ -0,0 +1,12 @@ +{-| +Module : Instana.SDK.Internal.Util +Description : Utilities +-} +module Instana.SDK.Internal.Util + ( (|>) + ) where + + +(|>) :: a -> (a -> b) -> b +(|>) = + flip ($) diff --git a/src/Instana/SDK/Internal/Worker.hs b/src/Instana/SDK/Internal/Worker.hs new file mode 100644 --- /dev/null +++ b/src/Instana/SDK/Internal/Worker.hs @@ -0,0 +1,449 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-| +Module : Instana.SDK.Internal.Worker +Description : Manages the SDKs background worker threads +-} +module Instana.SDK.Internal.Worker + ( spawnWorker + ) where + + +import qualified Control.Concurrent as Concurrent +import qualified Control.Concurrent.STM as STM +import Control.Exception (SomeException, + catch) +import Control.Monad (forever, + when) +import qualified Data.Aeson as Aeson +import Data.Foldable (toList) +import Data.List (map) +import Data.Sequence ((|>)) +import qualified Data.Sequence as Seq +import Data.Time.Clock.POSIX (getPOSIXTime) +import qualified Network.HTTP.Client as HTTP +import qualified Network.HTTP.Types.Status as HttpTypes +import System.Log.Logger (debugM, + warningM) +import qualified System.Metrics as Metrics + +import qualified Instana.SDK.Internal.AgentConnection.ConnectLoop as ConnectLoop +import Instana.SDK.Internal.AgentConnection.Paths (haskellEntityDataPathPrefix, + haskellTracePluginPath) +import Instana.SDK.Internal.Command (Command (..)) +import qualified Instana.SDK.Internal.Config as InternalConfig +import Instana.SDK.Internal.Context (AgentConnection (..), + ConnectionState (..), + InternalContext) +import qualified Instana.SDK.Internal.Context as InternalContext +import Instana.SDK.Internal.FullSpan (FullSpan (FullSpan), + FullSpanWithPid (FullSpanWithPid), + SpanKind (Entry, Exit)) +import qualified Instana.SDK.Internal.FullSpan as FullSpan +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.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 + + +-- |Spawns the SDK's worker. There should only be one worker at any time. +spawnWorker :: InternalContext -> IO() +spawnWorker context = do + debugM instanaLogger "Spawning the Instana Haskell SDK worker" + + -- The worker starts five threads, which continuously: + -- + -- 1) Check if the connection to the agent is already/still up. If not, this + -- thread will start to establish a connection to the agent. + _ <- Concurrent.forkIO $ ConnectLoop.initConnectLoop context + + -- 2) Read commands (incoming spans) from the command queue and put arriving + -- spans into the worker's local span buffer. This will happen regardless + -- of the agent connection state. If a certain amount of spans are in the + -- local buffer, we'll drain the buffer and, if connected, try to send the + -- spans to the agent. If not connected, these spans will be dropped. This + -- avoids excessive memory consumption at the expense of losing spans. + _ <- Concurrent.forkIO $ initReadLoop context + + -- 3) Drain the local span buffer once every second and try to send the + -- buffered spans, if any. Again, sending the spans will only be attempted + -- when connected, see above. + _ <- Concurrent.forkIO $ initDrainSpanBufferAfterTimeoutLoop context + + -- 4) Collect and send metrics, if connected. + _ <- Concurrent.forkIO $ collectAndSendMetricsLoop context + + -- 5) Make sure full metrics instad of diffs get send every five minutes + _ <- Concurrent.forkIO $ resetPreviouslySendMetrics context + + return () + + +{-| Read commands (incoming spans) from the command queue and put arriving spans +into the worker's local span buffer. This will happen regardless of the agent +connection state. If a certain amount of spans are in the local buffer, we'll +drain the buffer and, if connected, try to send the spans to the agent. If not +connected, these spans will be dropped. This avoids excessive memory consumption +at the expense of losing spans. +-} +initReadLoop :: InternalContext -> IO() +initReadLoop context = + forever $ readFromQueue context + + +readFromQueue :: InternalContext -> IO () +readFromQueue context = + catch + ( do + let + commandQueue = InternalContext.commandQueue context + command <- STM.atomically $ STM.readTQueue commandQueue + execute command context + ) + -- exceptions in execute (or reading from queue) must not kill the loop, so + -- we just catch everything + (\e -> warningM instanaLogger $ show (e :: SomeException)) + + +execute :: Command -> InternalContext -> IO () +execute (CompleteEntry entrySpan) = + queueEntrySpan entrySpan +execute (CompleteExit exitSpan) = + queueExitSpan exitSpan + + +queueEntrySpan :: EntrySpan -> InternalContext -> IO () +queueEntrySpan entrySpan context = do + now <- round . (* 1000) <$> getPOSIXTime + let + timestamp = EntrySpan.timestamp entrySpan + queueSpan + context + FullSpan + { FullSpan.traceId = EntrySpan.traceId entrySpan + , FullSpan.spanId = EntrySpan.spanId entrySpan + , FullSpan.parentId = EntrySpan.parentId entrySpan + , FullSpan.spanName = EntrySpan.spanName entrySpan + , FullSpan.timestamp = timestamp + , FullSpan.duration = now - timestamp + , FullSpan.kind = Entry + , FullSpan.errorCount = EntrySpan.errorCount entrySpan + , FullSpan.spanData = EntrySpan.spanData entrySpan + } + + +queueExitSpan :: ExitSpan -> InternalContext -> IO () +queueExitSpan exitSpan context = do + let + parentSpan = ExitSpan.parentSpan exitSpan + now <- round . (* 1000) <$> getPOSIXTime + queueSpan + context + FullSpan + { FullSpan.traceId = EntrySpan.traceId parentSpan + , FullSpan.spanId = ExitSpan.spanId exitSpan + , FullSpan.parentId = Just $ EntrySpan.spanId parentSpan + , FullSpan.spanName = ExitSpan.spanName exitSpan + , FullSpan.timestamp = ExitSpan.timestamp exitSpan + , FullSpan.duration = now - ExitSpan.timestamp exitSpan + , FullSpan.kind = Exit + , FullSpan.errorCount = ExitSpan.errorCount exitSpan + , FullSpan.spanData = ExitSpan.spanData exitSpan + } + + +queueSpan :: InternalContext -> FullSpan -> IO () +queueSpan context span_ = do + currentSpanQueue <- + STM.atomically $ + STM.readTVar $ + InternalContext.spanQueue context + let + bufferedSpans = Seq.length currentSpanQueue + maxBufferedSpans = + InternalConfig.maxBufferedSpans $ InternalContext.config context + forceTransmissionStartingAt = + InternalConfig.forceTransmissionStartingAt $ + InternalContext.config context + if bufferedSpans >= maxBufferedSpans + then do + -- TODO remove debug log? + debugM instanaLogger "dropping span, buffer limit reached" + return () + else do + STM.atomically $ + STM.modifyTVar + (InternalContext.spanQueue context) + (\q -> q |> span_) + when + (bufferedSpans + 1 >= forceTransmissionStartingAt) + (drainSpanBuffer context) + + +{-| Drain the local span buffer once every second and try to send the buffered +spans to the agent, if any. Sending the spans will only be attempted when the +connection to the agent is up, otherwise, the locally buffered spans will be +dropped. This avoids excessive memory consumption at the expense of losing +spans. +-} +initDrainSpanBufferAfterTimeoutLoop :: InternalContext -> IO() +initDrainSpanBufferAfterTimeoutLoop context = do + let + delayMilliSeconds = + InternalConfig.forceTransmissionAfter $ InternalContext.config context + delayMicroSeconds = delayMilliSeconds * 1000 + forever $ drainSpanBufferAfterTimeoutLoop delayMicroSeconds context + + +drainSpanBufferAfterTimeoutLoop :: Int -> InternalContext -> IO() +drainSpanBufferAfterTimeoutLoop delayMicroSeconds context = do + catch + ( do + drainSpanBuffer context + ) + -- exceptions in drainSpanBuffer must not kill the loop, so we just catch + -- everything + (\e -> warningM instanaLogger $ show (e :: SomeException)) + Concurrent.threadDelay delayMicroSeconds + + +drainSpanBuffer :: InternalContext -> IO () +drainSpanBuffer context = do + spansSeq <- STM.atomically $ + STM.swapTVar (InternalContext.spanQueue context) Seq.empty + let + spans :: [FullSpan] + spans = toList spansSeq + when (not $ null spans) $ do + InternalContext.whenConnected context $ + sendSpansToAgent context spans + + +sendSpansToAgent :: + InternalContext + -> [FullSpan] + -> AgentConnection + -> Metrics.Store + -> IO () +sendSpansToAgent context spans agentConnection _ = do + let + agentHost = InternalContext.agentHost agentConnection + agentPort = InternalContext.agentPort agentConnection + translatedPidStr = InternalContext.pid agentConnection + traceEndpointUrl = + (show $ + URL.mkHttp agentHost agentPort haskellTracePluginPath + ) ++ "." ++ translatedPidStr + -- combine actual span data with static per-process data (e.g. PID) + spansWithPid = map + (\fullSpan -> + FullSpanWithPid { + FullSpan.fullSpan = fullSpan + , FullSpan.pid = translatedPidStr + } + ) spans + defaultRequestSettings <- HTTP.parseUrlThrow traceEndpointUrl + let + request = + defaultRequestSettings + { HTTP.method = "POST" + , HTTP.requestBody = HTTP.RequestBodyLBS $ Aeson.encode spansWithPid + , HTTP.requestHeaders = + [ ("Accept", "application/json") + , ("Content-Type", "application/json; charset=UTF-8'") + ] + } + + -- TODO Would we want to retry the request? Or do we just lose this batch + -- of spans? Perhaps do 3 quick retries before giving up, maybe excluding a + -- 404 response status (because that clearly indicates that a new connection + -- establishment process has to be initiated. + + -- Right now, if sending the spans fails (either in the context of + -- drainSpanBufferAfterTimeoutLoop or queueSpan), the exception will be + -- logged and we move on. + -- That means that if the agent is unavailable for some time, we will try to + -- send spans at least every second regardless (or even more frequent, if the + -- monitored application creates more than 1000 spans per second). + -- We could do something more sophisticated here like trying to send spans + -- less frequently after a number of failed attempts. Maybe we could use + -- http://hackage.haskell.org/package/glue-0.2.0/docs/Glue-CircuitBreaker.html + -- + -- Also, as a small performance improvement, we might want to stop _accepting_ + -- spans until the connection has been reestablished. (To avoid serializing + -- a lot of spans to JSON if they can not be send due to agent + -- unavailability.) + catch + (do + _ <- HTTP.httpLbs request $ InternalContext.httpManager context + return () + ) + (\(e :: HTTP.HttpException) -> do + let + statusCode = + case e of + HTTP.HttpExceptionRequest _ (HTTP.StatusCodeException response _) -> + HttpTypes.statusCode (HTTP.responseStatus response) + _ -> + 0 + if statusCode == 404 + then + resetToUnconnected context + else do + debugM instanaLogger $ show e + return () + ) + + +collectAndSendMetricsLoop :: InternalContext -> IO() +collectAndSendMetricsLoop context = do + let + delayMicroSeconds = 1000 * 1000 -- once each second + -- offset metrics collection from span buffer draining + Concurrent.threadDelay $ 500 * 1000 + forever $ collectAndSendMetricsSafe delayMicroSeconds context + + +-- |Resets the previously send metrics to an empty map so we send the full set +-- of metrics the next time (instead of just the diff). +resetPreviouslySendMetrics :: InternalContext -> IO() +resetPreviouslySendMetrics context = do + let + delayMicroSeconds = 5 * 60 * 1000 * 1000 -- once every five minutes + forever $ do + catch + (STM.atomically $ STM.modifyTVar + (InternalContext.previousMetricsSample context) + Sample.markForReset + ) + (\e -> warningM instanaLogger $ show (e :: SomeException)) + Concurrent.threadDelay delayMicroSeconds + + +collectAndSendMetricsSafe :: Int -> InternalContext -> IO() +collectAndSendMetricsSafe delayMicroSeconds context = do + catch + ( do + collectAndSendMetricsWhenConnected context + ) + -- exceptions in collectAndSendMetrics must not kill the loop, so we just catch + -- everything + (\e -> warningM instanaLogger $ show (e :: SomeException)) + Concurrent.threadDelay delayMicroSeconds + + +collectAndSendMetricsWhenConnected :: InternalContext -> IO () +collectAndSendMetricsWhenConnected context = + InternalContext.whenConnected context $ + collectAndSendMetrics context + + +collectAndSendMetrics :: + InternalContext + -> AgentConnection + -> Metrics.Store + -> IO () +collectAndSendMetrics context agentConnection metricsStore = do + previousSample <- + STM.atomically $ STM.readTVar $ InternalContext.previousMetricsSample context + now <- round . (* 1000) <$> getPOSIXTime + sampledMetrics <- MetricsCollector.sampleAll metricsStore + let + currentSample = Sample.timedSampleFromEkgSample sampledMetrics now + enrichedSample = Deltas.enrichWithDeltas previousSample currentSample + compressedMetrics = + MetricsCompression.compressSample + (Sample.sample previousSample) + (Sample.sample enrichedSample) + + agentHost = InternalContext.agentHost agentConnection + agentPort = InternalContext.agentPort agentConnection + translatedPidStr = InternalContext.pid agentConnection + metricsEndpointUrl = + URL.mkHttp + agentHost + agentPort + (haskellEntityDataPathPrefix ++ translatedPidStr) + defaultRequestSettings <- HTTP.parseUrlThrow $ show metricsEndpointUrl + let + request = + defaultRequestSettings + { HTTP.method = "POST" + , HTTP.requestBody = + HTTP.RequestBodyLBS $ + Aeson.encode $ Sample.SampleJson compressedMetrics + , HTTP.requestHeaders = + [ ("Accept", "application/json") + , ("Content-Type", "application/json; charset=UTF-8'") + ] + } + + -- TODO Would we want to retry the request? Or do we just lose this batch + -- of data? Perhaps do 3 quick retries before giving up, maybe excluding a + -- 404 response status (because that clearly indicates that a new connection + -- establishment process has to be initiated. + + -- Right now, if sending the data fails, the exception will be logged and we + -- move on. + -- That means that if the agent is unavailable for some time, we will try to + -- send data at least every second regardless. + -- We could do something more sophisticated here like trying to send spans + -- less frequently after a number of failed attempts. Maybe we could use + -- http://hackage.haskell.org/package/glue-0.2.0/docs/Glue-CircuitBreaker.html + -- + -- Also, as a small performance improvement, we might want to stop + -- _collecting_ metrics until the connection has been reestablished. + catch + (do + _ <- HTTP.httpLbs request $ InternalContext.httpManager context + _ <- STM.atomically $ + STM.writeTVar + (InternalContext.previousMetricsSample context) + enrichedSample + return () + ) + (\(e :: HTTP.HttpException) -> do + let + statusCode = + case e of + HTTP.HttpExceptionRequest _ (HTTP.StatusCodeException response _) -> + HttpTypes.statusCode (HTTP.responseStatus response) + _ -> + 0 + if statusCode == 404 + then + resetToUnconnected context + else do + debugM instanaLogger $ show e + return () + ) + + +-- |Resets the agent connection to unconnected but only if it is currently +-- in state AgentReady (that is, the connection is fully established). This +-- triggers a new sensor agent handshake. The reasoning behind resetting it only +-- when it is in state AgentReady is that we do not want to interfer with any +-- attempts to establish a connection that is currently in flight, we only want +-- to record the fact that we have lost the connection if we thought we were +-- connected but are not. +resetToUnconnected :: InternalContext -> IO () +resetToUnconnected context = do + STM.atomically $ + STM.modifyTVar' + (InternalContext.connectionState context) + (\state -> + case state of + AgentReady _ -> + Unconnected + _ -> + state + ) + diff --git a/src/Instana/SDK/SDK.hs b/src/Instana/SDK/SDK.hs new file mode 100644 --- /dev/null +++ b/src/Instana/SDK/SDK.hs @@ -0,0 +1,890 @@ +{-# LANGUAGE OverloadedStrings #-} +{-| +Module : Instana.SDK.SDK +Description : The main API of the Instana Haskell Trace SDK. + +Instana.SDK.SDK is the main API of the Instana Haskell Trace SDK. Use one of +initInstana, initConfiguredInstana, withInstana, or withConfiguredInstana to get +an InstanaContext. Then use the context with any of the withRootEntry, +withEntry, withExit functions for tracing. +-} +module Instana.SDK.SDK + ( Config + , InstanaContext + , addData + , addDataAt + , addHttpTracingHeaders + , addToErrorCount + , agentHost + , agentName + , agentPort + , completeEntry + , completeExit + , defaultConfig + , forceTransmissionAfter + , forceTransmissionStartingAt + , incrementErrorCount + , initConfiguredInstana + , initInstana + , maxBufferedSpans + , readHttpTracingHeaders + , startEntry + , startExit + , startHttpEntry + , startHttpExit + , startRootEntry + , withConfiguredInstana + , withEntry + , withExit + , withHttpEntry + , withHttpExit + , withInstana + , withRootEntry + ) 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.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 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 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 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.Span (Span (..), SpanKind (..)) +import qualified Instana.SDK.Span.Span as Span +import Instana.SDK.TracingHeaders (TracingHeaders (TracingHeaders)) +import qualified Instana.SDK.TracingHeaders as TracingHeaders + + +{-| A container for all the things the Instana SDK needs to do its work. +-} +type InstanaContext = InternalContext + + +{-| Initializes the Instana SDK and the connection to the Instana agent. + +The configuration is read from the environment, falling back to default values. +-} +initInstana :: MonadIO m => m InstanaContext +initInstana = do + conf <- liftIO $ InternalConfig.readConfigFromEnvironmentAndApplyDefaults + liftIO $ initInstanaInternal conf + + +{-| Initializes the Instana SDK and the connection to the Instana agent, then +calls the given function with the established connection. + +The configuration is read from the environment, falling back to default values. +-} +withInstana :: MonadIO m => (InstanaContext -> m a) -> m a +withInstana fn = do + conf <- liftIO InternalConfig.readConfigFromEnvironmentAndApplyDefaults + withInstanaInternal conf fn + + +{-| Initializes the Instana SDK and the connection to the Instana agent, using +the given Instana configuration. + +Configuration settings that have not been set in the given configuration are +read from the environment, falling back to default values. +-} +initConfiguredInstana :: MonadIO m => Config -> m InstanaContext +initConfiguredInstana conf = do + confFromEnv <- liftIO $ InternalConfig.readConfigFromEnvironment + let + mergedConf = InternalConfig.mergeConfigs conf confFromEnv + liftIO $ initInstanaInternal mergedConf + + +{-| Initializes the Instana SDK and the connection to the Instana agent, then +calls the given function with the established connection, using the given +Instana configuration. + +Configuration settings that have not been set in the given configuration are +read from the environment, falling back to default values. +-} +withConfiguredInstana :: MonadIO m => Config -> (InstanaContext -> m a) -> m a +withConfiguredInstana conf fn = do + confFromEnv <- liftIO $ InternalConfig.readConfigFromEnvironment + let + mergedConf = InternalConfig.mergeConfigs conf confFromEnv + withInstanaInternal mergedConf fn + + +withInstanaInternal :: + MonadIO m => + FinalConfig + -> (InstanaContext -> m a) + -> m a +withInstanaInternal conf fn = do + context <- liftIO $ initInstanaInternal conf + fn context + + +initInstanaInternal :: FinalConfig -> IO InstanaContext +initInstanaInternal conf = do + now <- round . (* 1000) <$> getPOSIXTime + pid <- Process.getProcessID + Logging.initLogger $ show pid + commandQueue <- STM.newTQueueIO + spanQueue <- STM.newTVarIO $ Seq.empty + connectionState <- STM.newTVarIO $ Unconnected + fileDescriptor <- STM.newTVarIO $ Nothing + threadId <- Concurrent.myThreadId + currentSpans <- STM.newTVarIO $ Map.singleton threadId SpanStack.empty + previousMetricsSample <- STM.newTVarIO $ Sample.empty now + -- HTTP.newManager is keep-alive by default (10 connections, we set it to 5) + manager <- HTTP.newManager $ + HTTP.defaultManagerSettings + { HTTP.managerConnCount = 5 + , HTTP.managerResponseTimeout = HTTP.responseTimeoutMicro $ 5000 * 1000 + , HTTP.managerRawConnection = + HTTP.rawConnectionModifySocket + (\socket -> do + let + fileDescriptorFromSocket = Socket.fdSocket socket + STM.atomically $ + STM.writeTVar fileDescriptor (Just fileDescriptorFromSocket) + ) + } + let + context = + InternalContext + { InternalContext.config = conf + -- sdkStartTime will be used to approximate the process start time on + -- non-Linux platforms where System.SysInfo is not available. The + -- assumption is that the SDK is initialized right at the start of the + -- process. + , InternalContext.sdkStartTime = now + , InternalContext.httpManager = manager + , InternalContext.commandQueue = commandQueue + , InternalContext.spanQueue = spanQueue + , InternalContext.connectionState = connectionState + , InternalContext.fileDescriptor = fileDescriptor + , InternalContext.currentSpans = currentSpans + , InternalContext.previousMetricsSample = previousMetricsSample + } + -- The worker thread will also try to establish the connection to the agent + -- and only start its work when that was successful. + Worker.spawnWorker context + return context + + +-- |Wraps an IO action in 'startRootEntry' and 'completeEntry'. +withRootEntry :: + MonadIO m => + InstanaContext + -> Text + -> m a + -> m a +withRootEntry context spanName io = do + startRootEntry context spanName + result <- io + completeEntry context + return result + + +-- |Wraps an IO action in 'startEntry' and 'completeEntry'. +withEntry :: + MonadIO m => + InstanaContext + -> String + -> String + -> Text + -> m a + -> m a +withEntry context traceId parentId spanName io = do + startEntry context traceId parentId spanName + result <- io + completeEntry context + return result + + +-- |A convenience function that examines the given request for Instana tracing +-- headers (https://docs.instana.io/core_concepts/tracing/#http-tracing-headers) +-- and wraps the given IO action either in 'startRootEntry' or 'startEntry' and +-- 'completeEntry', depending on the presence or absence of these headers. +withHttpEntry :: + MonadIO m => + InstanaContext + -> Wai.Request + -> Text + -> m a + -> m a +withHttpEntry context request spanName io = do + let + tracingHeaders = readHttpTracingHeaders request + traceId = TracingHeaders.traceId tracingHeaders + spanId = TracingHeaders.spanId tracingHeaders + level = TracingHeaders.level tracingHeaders + case level of + TracingHeaders.Trace -> do + let + io' = addDataFromRequest context request io + case (traceId, spanId) of + (Just t, Just s) -> + withEntry context t s spanName io' + _ -> + withRootEntry context spanName 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 -> m a -> m a +addDataFromRequest context request originalIO = + originalIO >>= addHttpDataInIO context request + + +addHttpDataInIO :: MonadIO m => InstanaContext -> Wai.Request -> a -> m a +addHttpDataInIO context request ioResult = do + addHttpData context request + return ioResult + + +addHttpData :: MonadIO m => InstanaContext -> Wai.Request -> m () +addHttpData context request = do + let + host :: String + host = + Wai.requestHeaderHost request + |> fmap BSC8.unpack + |> Maybe.fromMaybe "" + addData + 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) + ] + ] + ) + + +-- |Wraps an IO action in 'startExit' and 'completeExit'. +withExit :: + MonadIO m => + InstanaContext + -> Text + -> m a + -> m a +withExit context spanName io = do + startExit context spanName + result <- io + completeExit context + return result + + +-- |Wraps an IO action in 'startHttpExit' and 'completeExit'. The given action +-- is accepted as a function (Request -> IO a) and is expected to use the +-- provided request parameter for executing the HTTP request. +withHttpExit :: + MonadIO m => + InstanaContext + -> HTTP.Request + -> (HTTP.Request -> m a) + -> m a +withHttpExit context request io = do + request' <- startHttpExit context request + result <- io request' + completeExit context + return result + + +-- |Creates a preliminary/incomplete root entry span, which should later be +-- completed with 'completeEntry'. +startRootEntry :: + MonadIO m => + InstanaContext + -> Text + -> m () +startRootEntry context spanName = do + liftIO $ do + timestamp <- round . (* 1000) <$> getPOSIXTime + traceId <- Id.generate + let + newSpan = + RootEntrySpan $ + RootEntry + { RootEntry.spanAndTraceId = traceId + , RootEntry.spanName = spanName + , RootEntry.timestamp = timestamp + , RootEntry.errorCount = 0 + , RootEntry.spanData = emptyValue + } + pushSpan + context + (\stack -> + case stack of + Nothing -> + -- We did not initialise the span stack for this thread, do it now. + SpanStack.entry newSpan + Just spanStack -> + spanStack + |> SpanStack.push (Entry newSpan) + ) + + +-- |Creates a preliminary/incomplete entry span, which should later be completed +-- by calling 'completeEntry'. +startEntry :: + MonadIO m => + InstanaContext + -> String + -> String + -> Text + -> m () +startEntry context traceId parentId spanName = do + liftIO $ do + timestamp <- round . (* 1000) <$> getPOSIXTime + spanId <- Id.generate + let + newSpan = + NonRootEntrySpan $ + NonRootEntry + { NonRootEntry.traceId = Id.fromString traceId + , NonRootEntry.spanId = spanId + , NonRootEntry.parentId = Id.fromString parentId + , NonRootEntry.spanName = spanName + , NonRootEntry.timestamp = timestamp + , NonRootEntry.errorCount = 0 + , NonRootEntry.spanData = emptyValue + } + pushSpan + context + (\stack -> + case stack of + Nothing -> + -- We did not initialise the span stack for this thread, do it now. + SpanStack.entry newSpan + Just spanStack -> + spanStack + |> SpanStack.push (Entry newSpan) + ) + return () + + +-- |A convenience function that examines the given request for Instana tracing +-- headers (https://docs.instana.io/core_concepts/tracing/#http-tracing-headers) +-- and either calls 'startRootEntry' or 'startEntry', depending on the presence +-- of absence of these headers. +startHttpEntry :: + MonadIO m => + InstanaContext + -> Wai.Request + -> Text + -> m () +startHttpEntry context request spanName = do + let + tracingHeaders = readHttpTracingHeaders request + traceId = TracingHeaders.traceId tracingHeaders + spanId = TracingHeaders.spanId tracingHeaders + level = TracingHeaders.level tracingHeaders + case level of + TracingHeaders.Trace -> + case (traceId, spanId) of + (Just t, Just s) -> do + startEntry context t s spanName + addHttpData context request + _ -> do + startRootEntry context spanName + addHttpData context request + 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 + ) + + +-- |Creates a preliminary/incomplete exit span, which should later be completed +-- with 'completeExit'. +startExit :: + MonadIO m => + InstanaContext + -> Text + -> m () +startExit context spanName = do + liftIO $ do + suppressed <- isSuppressed context + if suppressed then + return () + else do + entrySpan <- peekSpan context + case entrySpan of + Just (Entry parent) -> do + spanId <- Id.generate + timestamp <- round . (* 1000) <$> getPOSIXTime + let + newSpan = + ExitSpan + { ExitSpan.parentSpan = parent + , ExitSpan.spanId = spanId + , ExitSpan.spanName = spanName + , ExitSpan.timestamp = timestamp + , ExitSpan.errorCount = 0 + , ExitSpan.spanData = emptyValue + } + pushSpan + context + (\stack -> + case stack of + Nothing -> + -- No entry present, it is invalid to push an exit onto the + -- stack without an entry. But we can at least init a stack + -- for the current thread. + SpanStack.empty + Just spanStack -> + spanStack + |> SpanStack.push (Exit newSpan) + ) + Just (Exit ex) -> do + warningM instanaLogger $ + "Cannot start exit span \"" ++ show spanName ++ + "\" since there is already an active exit span " ++ + "in progress: " ++ show ex + Nothing -> do + warningM instanaLogger $ + "Cannot start exit span \"" ++ show spanName ++ + "\" since there is no active entry span " ++ + "(actually, there is no active span at all)." + return () + + +-- |Creates a preliminary/incomplete http exit span, which should later be +-- completed with 'completeExit'. The Instana tracing headers are added to the +-- request and the modified request value is returned (use the return value of +-- this function to execute your request instead of the request value passed +-- into this function). +startHttpExit :: + MonadIO m => + InstanaContext + -> HTTP.Request + -> m HTTP.Request +startHttpExit context request = do + request' <- addHttpTracingHeaders context request + let + originalCheckResponse = HTTP.checkResponse request' + request'' = + request' + { HTTP.checkResponse = (\req res -> do + let + status = + res + |> HTTP.responseStatus + |> HTTPTypes.statusCode + addData context + (Aeson.object [ "http" .= + Aeson.object + [ "status" .= status + ] + ] + ) + originalCheckResponse req res + ) + } + port = ":" ++ (show $ HTTP.port request) + protocol = if HTTP.secure request then "https://" else "http://" + host = BSC8.unpack $ HTTP.host request + path = BSC8.unpack $ HTTP.path request + url = protocol ++ host ++ port ++ path + + startExit context "haskell.http.client" + addData + context + (Aeson.object [ "http" .= + Aeson.object + [ "method" .= (BSC8.unpack $ HTTP.method request) + , "url" .= url + , "params" .= (processQueryString $ HTTP.queryString request) + ] + ] + ) + return request'' + + +processQueryString :: BSC8.ByteString -> Text +processQueryString queryString = + let + matcher = Secrets.defaultSecretsMatcher + in + queryString + |> BSC8.unpack + |> T.pack + |> (\t -> if (not . T.null) t && T.head t == '?' then T.tail t else t) + |> T.splitOn "&" + |> List.map (T.splitOn "=") + |> List.filter + (\pair -> + List.length pair == 2 && + (not . Secrets.isSecret matcher) (List.head pair) + ) + |> List.map (T.intercalate "=") + |> T.intercalate "&" + + +-- |Completes an entry span, to be called at the last possible moment before the +-- call has been processed completely. +completeEntry :: + MonadIO m => + InstanaContext + -> m () +completeEntry context = do + liftIO $ do + (poppedSpan, warning) <- popSpan context EntryKind + case (poppedSpan, warning) of + (Just (Entry entrySpan), _) -> + enqueueCommand + context + (Command.CompleteEntry entrySpan) + (_, Just warnMessage) -> do + warningM instanaLogger $ + "Cannot complete entry span due to a span stack mismatch: " ++ + warnMessage + return () + _ -> do + warningM instanaLogger $ + "Cannot complete entry span due to a span stack mismatch - there " ++ + "is no active span or the currently active span is not an entry." + return () + + +-- |Completes an exit span, to be called as soon as the remote call has +-- returned. +completeExit :: + MonadIO m => + InstanaContext + -> m () +completeExit context = do + liftIO $ do + suppressed <- isSuppressed context + if suppressed then + return () + else do + (poppedSpan, warning) <- popSpan context ExitKind + case (poppedSpan, warning) of + (Just (Exit exitSpan), _) -> + enqueueCommand + context + (Command.CompleteExit exitSpan) + (_, Just warnMessage) -> do + warningM instanaLogger $ + "Cannot complete exit span due to a span stack mismatch: " ++ + warnMessage + _ -> do + warningM instanaLogger $ + "Cannot complete exit span due to a span stack mismatch - there " ++ + "is no active span or the currently active span is not an exit." + return () + + +-- |Increments the error count for the currently active span by one. Call this +-- between startEntry/startRootEntry/startExit and completeEntry/completeExit or +-- inside the IO action given to with withEntry/withExit/withRootEntry if an +-- error happens while processing the entry/exit. +-- +-- This is an alias for `addToErrorCount instanaContext 1`. +incrementErrorCount :: MonadIO m => InstanaContext -> m () +incrementErrorCount context = + addToErrorCount context 1 + + +-- |Increments the error count for the currently active span by one. Call this +-- between startEntry/startRootEntry/startExit and completeEntry/completeExit or +-- inside the IO action given to with withEntry/withExit/withRootEntry if an +-- error happens while processing the entry/exit. +addToErrorCount :: MonadIO m => InstanaContext -> Int -> m () +addToErrorCount context increment = + liftIO $ modifyCurrentSpan context + (\span_ -> Span.addToErrorCount increment span_) + + +-- |Adds additional custom data to the currently active span. Call this +-- between startEntry/startRootEntry/startExit and completeEntry/completeExit or +-- inside the IO action given to with withEntry/withExit/withRootEntry. +-- The given path can be a nested path, with path fragments separated by dots, +-- like "http.url". This will result in +-- "data": { +-- ... +-- "http": { +-- "url": "..." +-- }, +-- ... +-- } +addDataAt :: (MonadIO m, Aeson.ToJSON a) => InstanaContext -> Text -> a -> m () +addDataAt context path value = + liftIO $ modifyCurrentSpan context + (\span_ -> Span.addDataAt path value span_) + + +-- |Adds additional custom data to the currently active span. Call this +-- between startEntry/startRootEntry/startExit and completeEntry/completeExit or +-- inside the IO action given to with withEntry/withExit/withRootEntry. Can be +-- called multiple times, data from multiple calls will be merged. +addData :: MonadIO m => InstanaContext -> Value -> m () +addData context value = + liftIO $ modifyCurrentSpan context + (\span_ -> Span.addData 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 + level = + headers + |> List.lookup TracingHeaders.levelHeaderName + |> (<$>) BSC8.unpack + in + TracingHeaders + { TracingHeaders.traceId = traceId + , TracingHeaders.spanId = spanId + , TracingHeaders.level = TracingHeaders.maybeStringToTracingLevel level + } + + +-- |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. +addHttpTracingHeaders :: + MonadIO m => + InstanaContext + -> HTTP.Request + -> m HTTP.Request +addHttpTracingHeaders context request = + liftIO $ do + suppressed <- isSuppressed context + entrySpan <- peekSpan context + let + originalHeaders = HTTP.requestHeaders request + updatedRequest = + case (entrySpan, suppressed) of + (_, True) -> + request { + HTTP.requestHeaders = + ((TracingHeaders.levelHeaderName, "0") : originalHeaders) + } + (Just (Entry currentEntrySpan), _) -> + request { + HTTP.requestHeaders = + (originalHeaders ++ + [ (TracingHeaders.traceIdHeaderName, Id.toByteString $ + EntrySpan.traceId currentEntrySpan) + , (TracingHeaders.spanIdHeaderName, Id.toByteString $ + EntrySpan.spanId currentEntrySpan) + ] + ) + } + _ -> + request + return updatedRequest + + +-- |Sends a command to the worker thread. +enqueueCommand :: InstanaContext -> Command -> IO () +enqueueCommand context command = do + -- TODO Maybe we better should use a bounded queue and drop stuff if we can't + -- keep up. For now, this is an unbounded queue that might turn into a memory + -- leak if a lot of spans are written and the HTTP requests to the agent can't + -- keep up. + let + commandQueue = InternalContext.commandQueue context + STM.atomically $ STM.writeTQueue commandQueue command + + +-- |Makes the given span the currently active span. +pushSpan :: + InstanaContext + -> (Maybe SpanStack -> SpanStack) + -> IO () +pushSpan context fn = do + threadId <- Concurrent.myThreadId + STM.atomically $ + STM.modifyTVar' + (InternalContext.currentSpans context) + (\currentSpansPerThread -> + let + modifiedStack = fn $ Map.lookup threadId currentSpansPerThread + in + Map.insert threadId modifiedStack currentSpansPerThread + ) + + +-- |Yields the currently active span, taking it of the stack. The span below +-- that will become the new active span (if there is any). +popSpan :: InstanaContext -> SpanKind -> IO (Maybe Span, Maybe String) +popSpan context expectedKind = do + threadId <- Concurrent.myThreadId + STM.atomically $ popSpanStm context threadId expectedKind + + +-- |Yields the currently active span, taking it of the stack. The span below +-- that will become the new active span (if there is any). +popSpanStm :: + InstanaContext + -> ThreadId + -> SpanKind + -> STM (Maybe Span, Maybe String) +popSpanStm context threadId expectedKind = do + currentSpansPerThread <- STM.readTVar $ InternalContext.currentSpans context + let + oldStack = Map.lookup threadId currentSpansPerThread + (modifiedStack, poppedSpan, warning) = + case oldStack of + Nothing -> + -- invalid state, there should be a stack with at least one span on it + ( SpanStack.empty + , Nothing + , Just $ "Invalid state: Trying to pop the span stack while there " ++ + "is no span stack for this thread yet." + ) + Just spanStack -> + SpanStack.popWhenMatches expectedKind spanStack + updatedSpansPerThread = + Map.insert threadId modifiedStack currentSpansPerThread + STM.writeTVar (InternalContext.currentSpans context) updatedSpansPerThread + return (poppedSpan, warning) + + +-- |Yields the currently active span without modifying the span stack. +peekSpan :: InstanaContext -> IO (Maybe Span) +peekSpan context = do + threadId <- Concurrent.myThreadId + STM.atomically $ peekSpanStm context threadId + + +-- |Yields the currently active span without modifying the span stack. +peekSpanStm :: InstanaContext -> ThreadId -> STM (Maybe Span) +peekSpanStm context threadId = do + currentSpansPerThread <- STM.readTVar $ InternalContext.currentSpans context + let + stack = Map.lookup threadId currentSpansPerThread + case stack of + Nothing -> + return Nothing + Just s -> + return $ SpanStack.peek s + + +-- |Checks if tracing is suppressed for the current thread. +isSuppressed :: InstanaContext -> IO Bool +isSuppressed context = do + threadId <- Concurrent.myThreadId + STM.atomically $ isSuppressedStm context threadId + + +-- |Checks if tracing is suppressed for the current thread. +isSuppressedStm :: InstanaContext -> ThreadId -> STM Bool +isSuppressedStm context threadId = do + currentSpansPerThread <- STM.readTVar $ InternalContext.currentSpans context + let + stack = Map.lookup threadId currentSpansPerThread + case stack of + Nothing -> + return False + Just s -> + return $ SpanStack.isSuppressed s + + +-- |Applies the given function to the currently active span, replacing it in +-- place with the result of the given function. +modifyCurrentSpan :: + InstanaContext + -> (Span -> Span) + -> IO () +modifyCurrentSpan context fn = do + threadId <- Concurrent.myThreadId + STM.atomically $ + STM.modifyTVar' (InternalContext.currentSpans context) + (\currentSpansPerThread -> + let + stack = Map.lookup threadId currentSpansPerThread + modifiedStack = mapCurrentSpan fn stack + in + Map.insert threadId modifiedStack currentSpansPerThread + ) + + +-- |Applies the given function to the given span. +mapCurrentSpan :: (Span -> Span) -> Maybe SpanStack -> SpanStack +mapCurrentSpan fn stack = + Maybe.fromMaybe + SpanStack.empty + ((SpanStack.mapTop fn) <$> stack) + + +-- |Provides an empty Aeson value. +emptyValue :: Value +emptyValue = Aeson.object [] + diff --git a/src/Instana/SDK/Span/EntrySpan.hs b/src/Instana/SDK/Span/EntrySpan.hs new file mode 100644 --- /dev/null +++ b/src/Instana/SDK/Span/EntrySpan.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE DeriveGeneric #-} +{-| +Module : Instana.SDK.Span.EntrySpan +Description : An entry span +-} +module Instana.SDK.Span.EntrySpan + ( EntrySpan(..) + , traceId + , spanId + , parentId + , spanName + , timestamp + , errorCount + , spanData + , addData + , addToErrorCount + ) where + + +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 + + +-- |An entry span. +data EntrySpan = + RootEntrySpan RootEntry + | NonRootEntrySpan NonRootEntry + deriving (Eq, Generic, Show) + + +-- |Accessor for the trace ID. +traceId :: EntrySpan -> Id +traceId entrySpan = + case entrySpan of + RootEntrySpan entry -> RootEntry.spanAndTraceId entry + NonRootEntrySpan entry -> NonRootEntry.traceId entry + + +-- |Accessor for the span ID. +spanId :: EntrySpan -> Id +spanId entrySpan = + case entrySpan of + RootEntrySpan entry -> RootEntry.spanAndTraceId entry + NonRootEntrySpan entry -> NonRootEntry.spanId entry + + +-- |Parent span ID. +parentId :: EntrySpan -> Maybe Id +parentId entrySpan = + case entrySpan of + RootEntrySpan _ -> Nothing + NonRootEntrySpan entry -> Just $ NonRootEntry.parentId entry + + +-- |Name of span. +spanName :: EntrySpan -> Text +spanName entrySpan = + case entrySpan of + RootEntrySpan entry -> RootEntry.spanName entry + NonRootEntrySpan entry -> NonRootEntry.spanName entry + + +-- |Start time. +timestamp :: EntrySpan -> Int +timestamp entrySpan = + case entrySpan of + RootEntrySpan entry -> RootEntry.timestamp entry + NonRootEntrySpan entry -> NonRootEntry.timestamp entry + + +-- |Error count (error that occured while this span has been active). +errorCount :: EntrySpan -> Int +errorCount entrySpan = + case entrySpan of + RootEntrySpan entry -> RootEntry.errorCount entry + NonRootEntrySpan entry -> NonRootEntry.errorCount entry + + +-- |Add to the error count. +addToErrorCount :: Int -> EntrySpan -> EntrySpan +addToErrorCount increment entrySpan = + case entrySpan of + RootEntrySpan entry -> + RootEntrySpan $ RootEntry.addToErrorCount increment entry + NonRootEntrySpan entry -> + NonRootEntrySpan $ NonRootEntry.addToErrorCount increment entry + + +-- |Optional additional span data. +spanData :: EntrySpan -> Value +spanData entrySpan = + case entrySpan of + RootEntrySpan entry -> RootEntry.spanData entry + NonRootEntrySpan entry -> NonRootEntry.spanData entry + + +-- |Add a value to the span's data section. +addData :: Value -> EntrySpan -> EntrySpan +addData value entrySpan = + case entrySpan of + RootEntrySpan entry -> + RootEntrySpan $ RootEntry.addData value entry + NonRootEntrySpan entry -> + NonRootEntrySpan $ NonRootEntry.addData value entry + diff --git a/src/Instana/SDK/Span/ExitSpan.hs b/src/Instana/SDK/Span/ExitSpan.hs new file mode 100644 --- /dev/null +++ b/src/Instana/SDK/Span/ExitSpan.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE DeriveGeneric #-} +{-| +Module : Instana.SDK.Span.ExitSpan +Description : An exit span +-} +module Instana.SDK.Span.ExitSpan + ( ExitSpan(..) + , parentId + , traceId + , addData + , addToErrorCount + ) where + + +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 + + +-- |An exit span. +data ExitSpan = + ExitSpan + { + -- |The parent span + parentSpan :: EntrySpan + -- |The span ID + , spanId :: Id + -- |The span name/type, e.g. a short string like "yesod", "servant", + -- "rpc-server", ... + , spanName :: Text + -- |The time the span started + , timestamp :: Int + -- |The number of errors that occured during processing + , errorCount :: Int + -- |Additional data for the span. Must be provided as an + -- 'Data.Aeson.Value'. + , spanData :: Value + } deriving (Eq, Generic, Show) + + +-- |Accessor for the trace ID. +traceId :: ExitSpan -> Id +traceId exitSpan = + EntrySpan.traceId $ parentSpan exitSpan + + +-- |Parent span ID. +parentId :: ExitSpan -> Id +parentId exitSpan = + EntrySpan.spanId $ parentSpan exitSpan + + +-- |Add to the error count. +addToErrorCount :: Int -> ExitSpan -> ExitSpan +addToErrorCount increment exitSpan = + let + ec = errorCount exitSpan + in + exitSpan { errorCount = ec + increment } + + +-- |Add a value to the span's data section. +addData :: Value -> ExitSpan -> ExitSpan +addData newData exitSpan = + let + currentData = spanData exitSpan + mergedData = AesonExtra.lodashMerge currentData newData + in + exitSpan { spanData = mergedData } + diff --git a/src/Instana/SDK/Span/NonRootEntry.hs b/src/Instana/SDK/Span/NonRootEntry.hs new file mode 100644 --- /dev/null +++ b/src/Instana/SDK/Span/NonRootEntry.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE DeriveGeneric #-} +{-| +Module : Instana.SDK.Span.NonRootEntry +Description : An entry span that is not the root of a trace +-} +module Instana.SDK.Span.NonRootEntry + ( NonRootEntry(..) + , addData + , addToErrorCount + ) where + + +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) + + +-- |An entry span that is not the root span of a trace. +data NonRootEntry = + NonRootEntry + { + -- |The trace ID + traceId :: Id + -- |The span ID + , spanId :: Id + -- |The ID of the parent span + , parentId :: Id + -- |The span name/type, e.g. a short string like "yesod", "servant", + -- "rpc-server", ... + , spanName :: Text + -- |The time the span started + , timestamp :: Int + -- |The number of errors that occured during processing + , errorCount :: Int + -- |Additional data for the span. Must be provided as an + -- 'Data.Aeson.Value'. + , spanData :: Value + } deriving (Eq, Generic, Show) + + +-- |Add to the error count. +addToErrorCount :: Int -> NonRootEntry -> NonRootEntry +addToErrorCount increment nonRootEntry = + let + ec = errorCount nonRootEntry + in + nonRootEntry { errorCount = ec + increment } + + +-- |Add a value to the span's data section. +addData :: Value -> NonRootEntry -> NonRootEntry +addData newData nonRootEntry = + let + currentData = spanData nonRootEntry + mergedData = AesonExtra.lodashMerge currentData newData + in + nonRootEntry { spanData = mergedData } + diff --git a/src/Instana/SDK/Span/RootEntry.hs b/src/Instana/SDK/Span/RootEntry.hs new file mode 100644 --- /dev/null +++ b/src/Instana/SDK/Span/RootEntry.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE DeriveGeneric #-} +{-| +Module : Instana.SDK.Span.RootEntry +Description : A root entry span +-} +module Instana.SDK.Span.RootEntry + ( RootEntry(..) + , spanId + , traceId + , addData + , addToErrorCount + ) where + + +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) + + +-- |An entry span that is the root span of a trace. +data RootEntry = + RootEntry + { + -- |The trace ID and span ID (those are identical for root spans) + spanAndTraceId :: Id + -- |The span name/type, e.g. a short string like "yesod", "servant", + , spanName :: Text + -- |The time the span (and trace) started + , timestamp :: Int + -- |The number of errors that occured during processing + , errorCount :: Int + -- |Additional data for the span. Must be provided as an + -- 'Data.Aeson.Value'. + , spanData :: Value + } deriving (Eq, Generic, Show) + + +-- |Accessor for the trace ID. +traceId :: RootEntry -> Id +traceId = spanAndTraceId + + +-- |Accessor for the span ID. +spanId :: RootEntry -> Id +spanId = spanAndTraceId + + +-- |Add to the error count. +addToErrorCount :: Int -> RootEntry -> RootEntry +addToErrorCount increment rootEntry = + let + ec = errorCount rootEntry + in + rootEntry { errorCount = ec + increment } + + +-- |Add a value to the span's data section. +addData :: Value -> RootEntry -> RootEntry +addData newData rootEntry = + let + currentData = spanData rootEntry + mergedData = AesonExtra.lodashMerge currentData newData + in + rootEntry { spanData = mergedData } + diff --git a/src/Instana/SDK/Span/Span.hs b/src/Instana/SDK/Span/Span.hs new file mode 100644 --- /dev/null +++ b/src/Instana/SDK/Span/Span.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-| +Module : Instana.SDK.Span.Span +Description : A type class for spans (entries and exits) +-} +module Instana.SDK.Span.Span + ( Span (Entry, Exit) + , SpanKind (EntryKind, ExitKind) + , traceId + , spanId + , spanKind + , parentId + , spanName + , timestamp + , errorCount + , addToErrorCount + , spanData + , addData + , addDataAt + ) where + + +import Data.Aeson (Value, (.=)) +import qualified Data.Aeson as Aeson +import qualified Data.List as List +import Data.Text as T +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.Span.ExitSpan (ExitSpan) +import qualified Instana.SDK.Span.ExitSpan as ExitSpan + + +data SpanKind = + -- |The monitored componenent receives a call. + EntryKind + -- |The monitored componenent calls something else. + | ExitKind + -- |An additional annotation that is added to the trace while a traced call + -- is being processed. + | IntermediateKind + deriving (Eq, Generic, Show) + + +data Span = + Entry EntrySpan + | Exit ExitSpan + deriving (Eq, Generic, Show) + + +-- |Accessor for the trace ID. +traceId :: Span -> Id +traceId span_ = + case span_ of + Entry entry -> EntrySpan.traceId entry + Exit exit -> ExitSpan.traceId exit + + +-- |Accessor for the span ID. +spanId :: Span -> Id +spanId span_ = + case span_ of + Entry entry -> EntrySpan.spanId entry + Exit exit -> ExitSpan.spanId exit + + +-- |Parent span ID. +parentId :: Span -> Maybe Id +parentId span_ = + case span_ of + Entry entry -> EntrySpan.parentId entry + Exit exit -> Just $ ExitSpan.parentId exit + + +-- |Name of span. +spanName :: Span -> Text +spanName span_ = + case span_ of + Entry entry -> EntrySpan.spanName entry + Exit exit -> ExitSpan.spanName exit + + +-- |Kind of span. +spanKind :: Span -> SpanKind +spanKind span_ = + case span_ of + Entry _ -> EntryKind + Exit _ -> ExitKind + + +-- |Start time. +timestamp :: Span -> Int +timestamp span_ = + case span_ of + Entry entry -> EntrySpan.timestamp entry + Exit exit -> ExitSpan.timestamp exit + + +-- |Start time. +errorCount :: Span -> Int +errorCount span_ = + case span_ of + Entry entry -> EntrySpan.errorCount entry + Exit exit -> ExitSpan.errorCount exit + + +-- |Add to the error count. +addToErrorCount :: Int -> Span -> Span +addToErrorCount increment span_ = + case span_ of + Entry entry -> + Entry $ EntrySpan.addToErrorCount increment entry + Exit exit -> + Exit $ ExitSpan.addToErrorCount increment exit + + +-- |Optional additional span data. +spanData :: Span -> Value +spanData span_ = + case span_ of + Entry entry -> EntrySpan.spanData entry + Exit exit -> ExitSpan.spanData exit + + +-- |Add a value to the span's data section. +addData :: Value -> Span -> Span +addData value span_ = + case span_ of + Entry entry -> Entry $ EntrySpan.addData value entry + Exit exit -> Exit $ ExitSpan.addData value exit + + +-- |Add a value at the given path to the span's data section. +addDataAt :: Aeson.ToJSON a => Text -> a -> Span -> Span +addDataAt path value span_ = + let + pathSegments = T.splitOn "." path + newData = List.foldr + (\nextPathSegment accumulatedAesonValue -> + Aeson.object [ + nextPathSegment .= accumulatedAesonValue + ] + ) + (Aeson.toJSON value) + pathSegments + in + addData newData span_ + diff --git a/src/Instana/SDK/TracingHeaders.hs b/src/Instana/SDK/TracingHeaders.hs new file mode 100644 --- /dev/null +++ b/src/Instana/SDK/TracingHeaders.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-| +Module : Instana.SDK.TracingHeaders +Description : A set of tracing headers +-} +module Instana.SDK.TracingHeaders + ( TracingHeaders(..) + , TracingLevel(..) + , levelHeaderName + , maybeStringToTracingLevel + , spanIdHeaderName + , stringToTracingLevel + , traceIdHeaderName + , tracingLevelToString + ) where + + +import GHC.Generics +import qualified Network.HTTP.Types.Header as HTTPHeader + + +traceIdHeaderName :: HTTPHeader.HeaderName +traceIdHeaderName = "X-INSTANA-T" + + +spanIdHeaderName :: HTTPHeader.HeaderName +spanIdHeaderName = "X-INSTANA-S" + + +levelHeaderName :: HTTPHeader.HeaderName +levelHeaderName = "X-INSTANA-L" + + +data TracingLevel = + -- |Record calls. + Trace + -- |Don't record calls. + | Suppress + deriving (Eq, Generic, Show) + + +stringToTracingLevel :: String -> TracingLevel +stringToTracingLevel s = + if s == "0" then Suppress else Trace + + +maybeStringToTracingLevel :: Maybe String -> TracingLevel +maybeStringToTracingLevel s = + if s == Just "0" then Suppress else Trace + + +tracingLevelToString :: TracingLevel -> String +tracingLevelToString l = + case l of + Trace -> "1" + Suppress -> "0" + + +-- |A set of tracing headers. +data TracingHeaders = + TracingHeaders + { + -- |the trace ID + traceId :: Maybe String + -- |the span ID + , spanId :: Maybe String + -- |the tracing level (on/off) + , level :: TracingLevel + } deriving (Eq, Generic, Show) + diff --git a/test/agent-stub/Instana/SDK/AgentStub/API.hs b/test/agent-stub/Instana/SDK/AgentStub/API.hs new file mode 100644 --- /dev/null +++ b/test/agent-stub/Instana/SDK/AgentStub/API.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +module Instana.SDK.AgentStub.API (API, proxyApi) where + + +import Servant + +import Instana.SDK.AgentStub.DiscoveryRequest (DiscoveryRequest) +import Instana.SDK.AgentStub.DiscoveryResponse (DiscoveryResponse) +import Instana.SDK.AgentStub.EntityDataRequest (EntityDataRequest) +import Instana.SDK.AgentStub.StubAPI (StubAPI) +import Instana.SDK.AgentStub.TraceRequest (TraceRequest) + + +type API = + -- GET / + Get '[JSON] (Headers '[Header "Server" String] NoContent) + + -- PUT /com.instana.plugin.haskell.discovery + :<|> "com.instana.plugin.haskell.discovery" + :> ReqBody '[JSON] DiscoveryRequest + :> Put '[JSON] DiscoveryResponse + + -- HEAD /com.instana.plugin.haskell.{pid} -> ready to accept? + :<|> Capture "pid" String + :> Head '[JSON] NoContent + + -- POST /com.instana.plugin.haskell.{pid} -> metrics a.k.a entity data + :<|> Capture "pid" String + :> ReqBody '[JSON] EntityDataRequest + :> Post '[JSON] NoContent + + -- POST /com.instana.plugin.haskell.discovery.{pid} + :<|> "com.instana.plugin.haskell" + :> Capture "pid" String + :> ReqBody '[JSON] TraceRequest + :> Post '[JSON] NoContent + + -- /stub/ sub API + :<|> "stub" + :> StubAPI + + +type Head = (Verb 'HEAD 200) + + +proxyApi :: Proxy API +proxyApi = Proxy + diff --git a/test/agent-stub/Instana/SDK/AgentStub/Config.hs b/test/agent-stub/Instana/SDK/AgentStub/Config.hs new file mode 100644 --- /dev/null +++ b/test/agent-stub/Instana/SDK/AgentStub/Config.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Instana.SDK.AgentStub.Config + ( AgentStubConfig(..) + , readConfig + ) where + + +import Data.Maybe (fromMaybe) +import Data.String (fromString) +import GHC.Generics +import qualified Network.Wai.Handler.Warp as Warp +import System.Environment (lookupEnv) +import Text.Read (readMaybe) + + +data AgentStubConfig = AgentStubConfig + { bindHost :: Warp.HostPreference + , bindPort :: Int + , agentName :: String + , startupDelay :: Int + , simulateConnectionLoss :: Bool + , simulatPidTranslation :: Bool + } deriving (Eq, Show, Generic) + + +readConfig :: IO AgentStubConfig +readConfig = do + -- Since the stub is only used locally, binding to host "127.0.0.1" is safer + -- and also more convenient than binding to something like "*4" + -- (see https://hackage.haskell.org/package/warp-3.2.9/docs/Network-Wai-Handler-Warp.html#t:HostPreference), + -- as it prevents the MacOS firewall from asking if it is okay to accept + -- incoming connections every time the app is recompiled and restarted. + hostString <- lookupEnvWithDefault "HOST" "127.0.0.1" + port <- lookupEnvIntWithDefault "PORT" 1302 + name <- lookupEnvWithDefault "AGENT_NAME" "Instana Agent" + delay <- lookupEnvIntWithDefault "STARTUP_DELAY" 0 + connectionLoss <- lookupFlag "SIMULATE_CONNECTION_LOSS" + pidTranslation <- lookupFlag "SIMULATE_PID_TRANSLATION" + let + hostPreference :: Warp.HostPreference + hostPreference = fromString hostString + return + AgentStubConfig + { bindHost = hostPreference + , bindPort = port + , agentName = name + , startupDelay = delay + , simulateConnectionLoss = connectionLoss + , simulatPidTranslation = pidTranslation + } + + +lookupEnvWithDefault :: String -> String -> IO String +lookupEnvWithDefault key defaultValue = do + maybeValue <- lookupEnv key + return $ fromMaybe defaultValue maybeValue + + +lookupEnvIntWithDefault :: String -> Int -> IO Int +lookupEnvIntWithDefault key defaultValue = do + maybeValue <- lookupEnv key + case maybeValue of + Just string -> do + let + parsed :: Maybe Int + parsed = readMaybe string + case parsed of + Just integer -> + return integer + Nothing -> do + _ <- error + ("Error: You provided the string \"" ++ string ++ + "\" as the value for configuration option " ++ key ++ + " but this option requires an integer value and I could" ++ + " not convert \"" ++ string ++ "\" to an integer.") + return defaultValue + Nothing -> + return defaultValue + + +lookupFlag :: String -> IO Bool +lookupFlag key = do + maybeValue <- lookupEnv key + return $ case maybeValue of + Just _ -> True + _ -> False + diff --git a/test/agent-stub/Instana/SDK/AgentStub/Logging.hs b/test/agent-stub/Instana/SDK/AgentStub/Logging.hs new file mode 100644 --- /dev/null +++ b/test/agent-stub/Instana/SDK/AgentStub/Logging.hs @@ -0,0 +1,45 @@ +module Instana.SDK.AgentStub.Logging + ( agentStubLogger + , initLogging + ) where + + +import System.IO (Handle, stdout) +import System.Log.Formatter +import System.Log.Handler (setFormatter) +import System.Log.Handler.Simple (GenericHandler, fileHandler, + streamHandler) +import System.Log.Logger (Priority (..), rootLoggerName, + setHandlers, setLevel, + updateGlobalLogger) + + +agentStubLogger :: String +agentStubLogger = "AgentStub" + + +logLevel :: Priority +logLevel = INFO + + +initLogging :: IO () +initLogging = do + updateGlobalLogger agentStubLogger $ setLevel logLevel + updateGlobalLogger rootLoggerName $ setLevel logLevel + agentStubFileHandler <- fileHandler "agent-stub.log" logLevel + agentStubStreamHandler <- streamHandler stdout logLevel + let + formattedAgentStubFileHandler = withFormatter agentStubFileHandler + formattedAgentStubStreamHandler = withFormatter agentStubStreamHandler + updateGlobalLogger agentStubLogger $ + setHandlers [ formattedAgentStubFileHandler ] + updateGlobalLogger rootLoggerName $ + setHandlers [ formattedAgentStubStreamHandler ] + + +withFormatter :: GenericHandler Handle -> GenericHandler Handle +withFormatter handler = setFormatter handler formatter + where + timeFormat = "%F %H:%M:%S.%4q %z" + formatter = tfLogFormatter timeFormat "<$time $loggername $pid $prio> $msg" + diff --git a/test/agent-stub/Instana/SDK/AgentStub/Main.hs b/test/agent-stub/Instana/SDK/AgentStub/Main.hs new file mode 100644 --- /dev/null +++ b/test/agent-stub/Instana/SDK/AgentStub/Main.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE OverloadedStrings #-} +module Instana.SDK.AgentStub.Main where + +import Control.Concurrent (threadDelay) +import Control.Monad (when) +import qualified Control.Monad.ST as ST +import Data.Time.Clock.POSIX (getPOSIXTime) +import qualified Network.Wai as Wai +import qualified Network.Wai.Handler.Warp as Warp +import qualified Servant +import System.Log.Logger (infoM) + +import qualified Instana.SDK.AgentStub.API as API +import Instana.SDK.AgentStub.Config (AgentStubConfig) +import qualified Instana.SDK.AgentStub.Config as Config +import Instana.SDK.AgentStub.Logging (agentStubLogger) +import qualified Instana.SDK.AgentStub.Logging as Logging +import Instana.SDK.AgentStub.Recorders (Recorders) +import qualified Instana.SDK.AgentStub.Recorders as Recorders +import qualified Instana.SDK.AgentStub.Server as Server + + +main :: IO () +main = do + Logging.initLogging + config <- Config.readConfig + recorders <- ST.stToIO $ Recorders.mkRecorders + startupTime <- round . (* 1000) <$> getPOSIXTime + let + host = Config.bindHost config + port = Config.bindPort config + startupDelay = Config.startupDelay config + serverSettings = + Warp.setHost host $ + Warp.setPort port $ + Warp.defaultSettings + infoM agentStubLogger $ "Starting agent stub bound to " ++ + (show $ Warp.getHost serverSettings) ++ " and port " ++ + (show $ Warp.getPort serverSettings) + when + (startupDelay > 0) + ( do + infoM agentStubLogger $ + "Artificial startup delay: " ++ show startupDelay ++ "ms, pausing." + threadDelay $ startupDelay * 1000 + infoM agentStubLogger $ + "Artificial startup delay has passed, resuming startup." + ) + Warp.runSettings serverSettings $ + app config startupTime recorders + + +app :: + AgentStubConfig + -> Int + -> Recorders + -> Wai.Application +app config startupTime recorders = + Servant.serve + API.proxyApi + (Server.mainServer + config + startupTime + recorders + ) + diff --git a/test/agent-stub/Instana/SDK/AgentStub/Recorders.hs b/test/agent-stub/Instana/SDK/AgentStub/Recorders.hs new file mode 100644 --- /dev/null +++ b/test/agent-stub/Instana/SDK/AgentStub/Recorders.hs @@ -0,0 +1,46 @@ +module Instana.SDK.AgentStub.Recorders where + + +import Control.Monad.ST (RealWorld, ST) +import Data.STRef (STRef, newSTRef) + +import Instana.SDK.AgentStub.DiscoveryRequest (DiscoveryRequest) +import Instana.SDK.AgentStub.EntityDataRequest (EntityDataRequest) +import Instana.SDK.AgentStub.TraceRequest (Span) + + +type DiscoverRecorder = STRef RealWorld [DiscoveryRequest] + + +type AgentReadyRecorder = STRef RealWorld [String] + + +type EntityDataRecorder = STRef RealWorld [EntityDataRequest] + + +type SpanRecorder = STRef RealWorld [Span] + + +data Recorders = + Recorders + { discoveryRecorder :: DiscoverRecorder + , agentReadyRecorder :: AgentReadyRecorder + , entityDataRecorder :: EntityDataRecorder + , spanRecorder :: SpanRecorder + } + + +mkRecorders :: ST RealWorld Recorders +mkRecorders = do + dr <- newSTRef [] + arr <- newSTRef [] + edr <- newSTRef [] + sr <- newSTRef [] + return $ + Recorders + { discoveryRecorder = dr + , agentReadyRecorder = arr + , entityDataRecorder = edr + , spanRecorder = sr + } + diff --git a/test/agent-stub/Instana/SDK/AgentStub/Server.hs b/test/agent-stub/Instana/SDK/AgentStub/Server.hs new file mode 100644 --- /dev/null +++ b/test/agent-stub/Instana/SDK/AgentStub/Server.hs @@ -0,0 +1,229 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +module Instana.SDK.AgentStub.Server (mainServer) where + + +import Control.Monad.IO.Class (liftIO) +import Data.List (isPrefixOf) +import qualified Data.List as List +import Data.Maybe (fromMaybe) +import Data.STRef (modifySTRef, + readSTRef) +import Data.Time.Clock.POSIX (getPOSIXTime) +import Servant ((:<|>) (..), Header, + Headers, + NoContent (NoContent), + err404, err503) +import qualified Servant +import System.Log.Logger (debugM, warningM) +import Text.Read (readMaybe) + +import Instana.SDK.AgentStub.API (API) +import Instana.SDK.AgentStub.Config (AgentStubConfig) +import qualified Instana.SDK.AgentStub.Config as Config +import Instana.SDK.AgentStub.DiscoveryRequest (DiscoveryRequest) +import qualified Instana.SDK.AgentStub.DiscoveryRequest as DiscoveryRequest +import Instana.SDK.AgentStub.DiscoveryResponse (DiscoveryResponse (DiscoveryResponse), + SecretsConfig (SecretsConfig)) +import qualified Instana.SDK.AgentStub.DiscoveryResponse as DiscoveryResponse +import Instana.SDK.AgentStub.EntityDataRequest (EntityDataRequest) +import Instana.SDK.AgentStub.Logging (agentStubLogger) +import Instana.SDK.AgentStub.Recorders (Recorders) +import qualified Instana.SDK.AgentStub.Recorders as Recorders +import qualified Instana.SDK.AgentStub.StubServer as StubServer +import Instana.SDK.AgentStub.TraceRequest (TraceRequest) +import Instana.SDK.AgentStub.Util (shouldSimulateConnectionLoss, + stToServant) + + +mainServer :: + AgentStubConfig + -> Int + -> Recorders + -> Servant.Server API +mainServer config startupTime recorders = + getRoot config + :<|> putDiscovery config startupTime recorders + :<|> headAgentReady config startupTime recorders + :<|> postEntityData config startupTime recorders + :<|> postTrace config startupTime recorders + :<|> StubServer.stubServer recorders + + +getRoot :: + AgentStubConfig + -> Servant.Handler (Headers '[Header "Server" String] NoContent) +getRoot config = + return $ Servant.addHeader (Config.agentName config) NoContent + + +putDiscovery :: + AgentStubConfig + -> Int + -> Recorders + -> DiscoveryRequest + -> Servant.Handler DiscoveryResponse +putDiscovery config startupTime recorders discoveryRequest = do + now <- liftIO $ round . (* 1000) <$> getPOSIXTime + if shouldSimulateConnectionLoss config startupTime now + then do + liftIO $ debugM agentStubLogger $ + "Rejecting PUT discovery to simulate connection loss." + Servant.throwError err503 + else do + liftIO $ + debugM agentStubLogger $ "PUT discovery " ++ show discoveryRequest + let + pidStr = DiscoveryRequest.pid discoveryRequest + pid = fromMaybe 0 $ readMaybe pidStr + translatedPid = + if Config.simulatPidTranslation config + then pid + 1 + else pid + translatedDiscoveryRequest = + discoveryRequest { DiscoveryRequest.pid = show translatedPid } + stToServant $ + modifySTRef + (Recorders.discoveryRecorder recorders) + ((++) [translatedDiscoveryRequest]) + return $ + DiscoveryResponse + { DiscoveryResponse.pid = translatedPid + , DiscoveryResponse.agentUuid = "agent-stub-id" + , DiscoveryResponse.extraHeaders = Nothing + , DiscoveryResponse.secrets = + SecretsConfig + { DiscoveryResponse.matcher = "contains-ignore-case" + , DiscoveryResponse.list = ["key", "pass", "secret"] + } + } + + +headAgentReady :: + AgentStubConfig + -> Int + -> Recorders + -> String + -> Servant.Handler NoContent +headAgentReady + config + startupTime + recorders + pidString + = do + now <- liftIO $ round . (* 1000) <$> getPOSIXTime + if shouldSimulateConnectionLoss config startupTime now + then do + liftIO $ debugM agentStubLogger $ + "Rejecting HEAD agent ready to simulate connection loss." + Servant.throwError err503 + else do + liftIO $ debugM agentStubLogger $ "HEAD " ++ pidString + recordedDiscoveries <- + stToServant $ readSTRef $ Recorders.discoveryRecorder recorders + let + pidStrWithoutPrefix = + if isPrefixOf "com.instana.plugin.haskell." pidString + then drop 27 pidString else "" + knownPids = List.map DiscoveryRequest.pid recordedDiscoveries + pidHasBeenAnnounced = elem pidStrWithoutPrefix knownPids + if pidHasBeenAnnounced + then do + stToServant $ + modifySTRef + (Recorders.agentReadyRecorder recorders) + ((++) [pidStrWithoutPrefix]) + return NoContent + else do + liftIO $ warningM agentStubLogger $ + "Rejecting agent ready request for unannounced PID " ++ + pidStrWithoutPrefix + Servant.throwError err404 + + +postEntityData :: + AgentStubConfig + -> Int + -> Recorders + -> String + -> EntityDataRequest + -> Servant.Handler NoContent +postEntityData + config + startupTime + recorders + pidString + entityData + = do + now <- liftIO $ round . (* 1000) <$> getPOSIXTime + if shouldSimulateConnectionLoss config startupTime now + then do + liftIO $ debugM agentStubLogger $ + "Rejecting POST entity data to simulate connection loss." + Servant.throwError err503 + else do + liftIO $ debugM agentStubLogger $ "POST entity data " ++ pidString + recordedDiscoveries <- + stToServant $ readSTRef $ Recorders.discoveryRecorder recorders + let + pidStrWithoutPrefix = + if isPrefixOf "com.instana.plugin.haskell." pidString + then drop 27 pidString else "" + knownPids = List.map DiscoveryRequest.pid recordedDiscoveries + pidHasBeenAnnounced = elem pidStrWithoutPrefix knownPids + if pidHasBeenAnnounced + then do + liftIO $ + debugM agentStubLogger $ + "accepting entity data " ++ show entityData + stToServant $ + modifySTRef + (Recorders.entityDataRecorder recorders) + ((++) [entityData]) + return NoContent + else do + liftIO $ warningM agentStubLogger $ + "Rejecting entity data request for unannounced PID " ++ + pidStrWithoutPrefix + Servant.throwError err404 + + +postTrace :: + AgentStubConfig + -> Int + -> Recorders + -> String + -> TraceRequest + -> Servant.Handler NoContent +postTrace + config + startupTime + recorders + pidString + traceRequest = do + now <- liftIO $ round . (* 1000) <$> getPOSIXTime + if shouldSimulateConnectionLoss config startupTime now + then do + liftIO $ debugM agentStubLogger $ + "Rejecting POST trace to simulate connection loss." + Servant.throwError err503 + else do + liftIO $ debugM agentStubLogger $ "POST " ++ pidString ++ + show traceRequest + recordedDiscoveries <- + stToServant $ readSTRef $ Recorders.discoveryRecorder recorders + let + pidStrWithoutTracesPrefix = + if isPrefixOf "traces." pidString then drop 7 pidString else "" + knownPids = List.map DiscoveryRequest.pid recordedDiscoveries + pidHasBeenAnnounced = elem pidStrWithoutTracesPrefix knownPids + if pidHasBeenAnnounced + then do + stToServant $ + modifySTRef (Recorders.spanRecorder recorders) ((++) traceRequest) + return NoContent + else do + liftIO $ warningM agentStubLogger $ + "Rejecting trace for unannounced PID " ++ pidStrWithoutTracesPrefix + Servant.throwError err404 + diff --git a/test/agent-stub/Instana/SDK/AgentStub/StubAPI.hs b/test/agent-stub/Instana/SDK/AgentStub/StubAPI.hs new file mode 100644 --- /dev/null +++ b/test/agent-stub/Instana/SDK/AgentStub/StubAPI.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +module Instana.SDK.AgentStub.StubAPI + ( StubAPI + , ResetAPI + ) where + + +import Servant + +import Instana.SDK.AgentStub.DiscoveryRequest (DiscoveryRequest) +import Instana.SDK.AgentStub.EntityDataRequest (EntityDataRequest) +import Instana.SDK.AgentStub.TraceRequest (Span) + + +type StubAPI = + -- GET /stub/ping + "ping" + :> GetNoContent '[JSON] NoContent + -- GET /stub/discoveries + :<|> "discoveries" + :> Get '[JSON] [DiscoveryRequest] + -- GET /stub/agent-ready + :<|> "agent-ready" + :> Get '[JSON] [String] + -- GET /stub/entity-data + :<|> "entity-data" + :> Get '[JSON] [EntityDataRequest] + -- GET /stub/spans + :<|> "spans" + :> Get '[JSON] [Span] + -- POST /stub/shutdown + :<|> "shutdown" + :> PostNoContent '[JSON] NoContent + :<|> "reset" + :> ResetAPI + + +type ResetAPI = + -- POST /stub/reset/discoveries + "discoveries" + :> PostNoContent '[JSON] NoContent + -- POST /stub/reset/agent-ready-requests + :<|> "spans" + :> PostNoContent '[JSON] NoContent + diff --git a/test/agent-stub/Instana/SDK/AgentStub/StubServer.hs b/test/agent-stub/Instana/SDK/AgentStub/StubServer.hs new file mode 100644 --- /dev/null +++ b/test/agent-stub/Instana/SDK/AgentStub/StubServer.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE OverloadedStrings #-} +module Instana.SDK.AgentStub.StubServer (stubServer) where + + +import Control.Monad.IO.Class (liftIO) +import Data.STRef (modifySTRef, + readSTRef) +import Servant ((:<|>) (..), + NoContent (NoContent)) +import qualified Servant +import qualified System.Exit as Exit +import System.Log.Logger (debugM, infoM) +import qualified System.Posix.Process as Posix + +import Instana.SDK.AgentStub.DiscoveryRequest (DiscoveryRequest) +import Instana.SDK.AgentStub.EntityDataRequest (EntityDataRequest) +import Instana.SDK.AgentStub.Logging (agentStubLogger) +import Instana.SDK.AgentStub.Recorders (Recorders) +import qualified Instana.SDK.AgentStub.Recorders as Recorders +import Instana.SDK.AgentStub.StubAPI (ResetAPI, StubAPI) +import Instana.SDK.AgentStub.TraceRequest (Span) +import Instana.SDK.AgentStub.Util (stToServant) + + +stubServer :: Recorders -> Servant.Server StubAPI +stubServer recorders = + getPing + :<|> getRecordedDiscoveries recorders + :<|> getRecordedAgentReadyRequests recorders + :<|> getRecordedEntityDataRequests recorders + :<|> getRecordedSpans recorders + :<|> postShutdown + :<|> resetServer recorders + + +getPing :: Servant.Handler NoContent +getPing = do + liftIO $ debugM agentStubLogger $ "ping" + return NoContent + + +getRecordedDiscoveries :: Recorders -> Servant.Handler [DiscoveryRequest] +getRecordedDiscoveries recorders = do + recordedDiscoveries <- + stToServant $ readSTRef $ Recorders.discoveryRecorder recorders + return recordedDiscoveries + + +getRecordedAgentReadyRequests :: Recorders -> Servant.Handler [String] +getRecordedAgentReadyRequests recorders = do + recordedAgentReadyPids <- + stToServant $ readSTRef $ Recorders.agentReadyRecorder recorders + return recordedAgentReadyPids + + +getRecordedEntityDataRequests :: + Recorders + -> Servant.Handler [EntityDataRequest] +getRecordedEntityDataRequests recorders = do + recordedEntityDataRequests <- + stToServant $ readSTRef $ Recorders.entityDataRecorder recorders + return recordedEntityDataRequests + + +getRecordedSpans :: Recorders -> Servant.Handler [Span] +getRecordedSpans recorders = do + recordedSpans <- stToServant $ readSTRef $ Recorders.spanRecorder recorders + return recordedSpans + + +postShutdown :: Servant.Handler NoContent +postShutdown = do + liftIO $ infoM agentStubLogger $ "AgentStub shutdown requested" + _ <-liftIO $ Posix.exitImmediately Exit.ExitSuccess + return NoContent + + +resetServer :: + Recorders + -> Servant.Server ResetAPI +resetServer recorders = + postResetDiscoveries recorders + :<|> postResetSpans recorders + + +postResetDiscoveries :: Recorders -> Servant.Handler NoContent +postResetDiscoveries recorders = do + liftIO $ debugM agentStubLogger $ + "resetting recorded discoveries, agent ready and entity data requests" + stToServant $ modifySTRef (Recorders.discoveryRecorder recorders) (\_ -> []) + stToServant $ modifySTRef (Recorders.agentReadyRecorder recorders) (\_ -> []) + stToServant $ + modifySTRef (Recorders.entityDataRecorder recorders) (\_ -> []) + return NoContent + + +postResetSpans :: Recorders -> Servant.Handler NoContent +postResetSpans recorders = do + liftIO $ debugM agentStubLogger $ "resetting recorded spans" + stToServant $ modifySTRef (Recorders.spanRecorder recorders) (\_ -> []) + return NoContent + diff --git a/test/agent-stub/Instana/SDK/AgentStub/Util.hs b/test/agent-stub/Instana/SDK/AgentStub/Util.hs new file mode 100644 --- /dev/null +++ b/test/agent-stub/Instana/SDK/AgentStub/Util.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE OverloadedStrings #-} +module Instana.SDK.AgentStub.Util + ( shouldSimulateConnectionLoss + , stToServant + ) where + + +import Control.Monad.IO.Class (liftIO) +import Control.Monad.ST (RealWorld, ST) +import qualified Control.Monad.ST as ST +import qualified Servant + +import Instana.SDK.AgentStub.Config (AgentStubConfig) +import qualified Instana.SDK.AgentStub.Config as Config + + +stToServant :: ST RealWorld a -> Servant.Handler a +stToServant = liftIO . ST.stToIO + + +shouldSimulateConnectionLoss :: AgentStubConfig -> Int -> Int -> Bool +shouldSimulateConnectionLoss config startupTime now = + -- Simulate connection loss after from 1500ms after server startup until + -- 3500ms seconds after startup. + Config.simulateConnectionLoss config && + (now > startupTime + 1500 && now < startupTime + 3500) + diff --git a/test/agent-stub/Main.hs b/test/agent-stub/Main.hs new file mode 100644 --- /dev/null +++ b/test/agent-stub/Main.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + + +import qualified Instana.SDK.AgentStub.Main as AgentStub + + +main :: IO () +main = + AgentStub.main + diff --git a/test/apps/wai/Main.hs b/test/apps/wai/Main.hs new file mode 100644 --- /dev/null +++ b/test/apps/wai/Main.hs @@ -0,0 +1,413 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + + +import Control.Concurrent (threadDelay) +import Control.Monad (join) +import Control.Monad.IO.Class (liftIO) +import Data.Aeson (Value, (.=)) +import qualified Data.Aeson as Aeson +import qualified Data.Binary.Builder as Builder +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy.Char8 as LBSC8 +import qualified Data.Maybe as Maybe +import qualified Data.Text as T +import Instana.SDK.SDK (InstanaContext) +import qualified Instana.SDK.SDK as InstanaSDK +import qualified Network.HTTP.Client as HTTP +import qualified Network.HTTP.Types as HTTPTypes +import qualified Network.Wai as Wai +import qualified Network.Wai.Handler.Warp as Warp +import qualified System.Exit as Exit +import System.IO (Handle, stdout) +import System.Log.Formatter +import System.Log.Handler (setFormatter) +import System.Log.Handler.Simple (GenericHandler, fileHandler, + streamHandler) +import System.Log.Logger (Priority (..), rootLoggerName, + setHandlers, setLevel, + updateGlobalLogger) +import System.Log.Logger (infoM) +import qualified System.Posix.Process as Posix +import System.Posix.Types (CPid) + + +appLogger :: String +appLogger = "WaiWarpApp" + + +application :: InstanaContext -> HTTP.Manager -> CPid -> Wai.Application +application instana httpManager pid request respond = do + let + route = Wai.pathInfo request + method = Wai.requestMethod request + case (method, route) of + (_, []) -> + root respond + (_, ["ping"]) -> + ping respond pid + ("POST", ["bracket", "api", "root"]) -> + bracketApiRootEntry instana respond + ("POST", ["bracket", "api", "non-root"]) -> + bracketApiNonRootEntry instana respond + ("POST", ["bracket", "api", "with-data"]) -> + bracketApiWithData instana respond + ("POST", ["low", "level", "api", "root"]) -> + lowLevelApiRootEntry instana respond + ("POST", ["low", "level", "api", "non-root"]) -> + lowLevelApiNonRootEntry instana respond + ("POST", ["low", "level", "api", "with-data"]) -> + lowLevelApiWithData instana respond + ("GET", ["http", "bracket", "api"]) -> + httpBracketApi instana httpManager request respond + ("GET", ["http", "low", "level", "api"]) -> + httpLowLevelApi instana httpManager request respond + ("POST", ["single"]) -> + createSingleSpan instana request respond + ("POST", ["shutdown"]) -> + shutDown respond + _ -> + respond404 respond + + +root :: + (Wai.Response -> IO Wai.ResponseReceived) + -> IO Wai.ResponseReceived +root respond = + respondWithPlainText + respond + "Instana Haskell Trace SDK Integration Test Wai Dummy App" + + +ping :: + (Wai.Response -> IO Wai.ResponseReceived) + -> CPid + -> IO Wai.ResponseReceived +ping respond pid = do + respond $ + Wai.responseLBS HTTPTypes.status200 [] $ LBSC8.pack $ show pid + + +bracketApiRootEntry :: + InstanaContext + -> (Wai.Response -> IO Wai.ResponseReceived) + -> IO Wai.ResponseReceived +bracketApiRootEntry instana respond = do + result <- + InstanaSDK.withRootEntry + instana + "haskell.dummy.root.entry" + (withExit instana) + respondWithPlainText respond $ result ++ "::entry done" + + +bracketApiNonRootEntry :: + InstanaContext + -> (Wai.Response -> IO Wai.ResponseReceived) + -> IO Wai.ResponseReceived +bracketApiNonRootEntry instana respond = do + result <- + InstanaSDK.withEntry + instana + "trace-id" + "parent-id" + "haskell.dummy.entry" + (withExit instana) + respondWithPlainText respond $ result ++ "::entry done" + + +withExit :: InstanaContext -> IO String +withExit instana = + InstanaSDK.withExit + instana + "haskell.dummy.exit" + simulateExitCall + + +bracketApiWithData :: + InstanaContext + -> (Wai.Response -> IO Wai.ResponseReceived) + -> IO Wai.ResponseReceived +bracketApiWithData instana respond = do + entryCallResult <- + InstanaSDK.withRootEntry + instana + "haskell.dummy.root.entry" + (withExitWithData instana) + respondWithPlainText respond $ entryCallResult + + +withExitWithData :: InstanaContext -> IO String +withExitWithData instana = do + InstanaSDK.addData instana (someSpanData "entry") + exitCallResult <- + InstanaSDK.withExit + instana + "haskell.dummy.exit" + (simulateExitCallWithData instana) + InstanaSDK.incrementErrorCount instana + InstanaSDK.addData instana (moreSpanData "entry") + return $ exitCallResult ++ "::entry done" + + +simulateExitCallWithData :: InstanaContext -> IO String +simulateExitCallWithData instana = do + InstanaSDK.addData instana (someSpanData "exit") + -- some time needs to pass, otherwise the exit span's duration will be 0 + threadDelay $ 10 * 1000 + InstanaSDK.addToErrorCount instana 2 + InstanaSDK.addData instana (moreSpanData "exit") + InstanaSDK.addDataAt instana "nested.key1" ("nested.text.value1" :: String) + InstanaSDK.addDataAt instana "nested.key2" ("nested.text.value2" :: String) + InstanaSDK.addDataAt instana "nested.key3" (1604 :: Int) + return "exit done" + + +lowLevelApiRootEntry :: + InstanaContext + -> (Wai.Response -> IO Wai.ResponseReceived) + -> IO Wai.ResponseReceived +lowLevelApiRootEntry instana respond = do + InstanaSDK.startRootEntry + instana + "haskell.dummy.root.entry" + result <- doExitCall instana + InstanaSDK.completeEntry instana + respondWithPlainText respond result + + +lowLevelApiNonRootEntry :: + InstanaContext + -> (Wai.Response -> IO Wai.ResponseReceived) + -> IO Wai.ResponseReceived +lowLevelApiNonRootEntry instana respond = do + InstanaSDK.startEntry + instana + "trace-id" + "parent-id" + "haskell.dummy.entry" + result <- doExitCall instana + InstanaSDK.completeEntry instana + respondWithPlainText respond result + + +doExitCall :: InstanaContext -> IO String +doExitCall instana = do + InstanaSDK.startExit + instana + "haskell.dummy.exit" + result <- simulateExitCall + InstanaSDK.completeExit instana + return result + + +lowLevelApiWithData :: + InstanaContext + -> (Wai.Response -> IO Wai.ResponseReceived) + -> IO Wai.ResponseReceived +lowLevelApiWithData instana respond = do + InstanaSDK.startRootEntry + instana + "haskell.dummy.root.entry" + InstanaSDK.addData instana (someSpanData "entry") + result <- doExitCallWithData instana + InstanaSDK.incrementErrorCount instana + InstanaSDK.addData instana (moreSpanData "entry") + InstanaSDK.addDataAt + instana "nested.entry.key" ("nested.entry.value" :: String) + InstanaSDK.completeEntry instana + respondWithPlainText respond result + + +doExitCallWithData :: InstanaContext -> IO String +doExitCallWithData instana = do + InstanaSDK.startExit + instana + "haskell.dummy.exit" + InstanaSDK.addData instana (someSpanData "exit") + result <- simulateExitCall + InstanaSDK.incrementErrorCount instana + InstanaSDK.addData instana (moreSpanData "exit") + InstanaSDK.addDataAt instana "nested.exit.key" ("nested.exit.value" :: String) + InstanaSDK.completeExit instana + return result + + +simulateExitCall :: IO String +simulateExitCall = do + -- some time needs to pass, otherwise the exit span's duration will be 0 + threadDelay $ 10 * 1000 + return "exit done" + + +someSpanData :: String -> Value +someSpanData kind = + Aeson.object + [ "data1" .= ("value1" :: String) + , "data2" .= (42 :: Int) + , "startKind" .= kind + ] + + +moreSpanData :: String -> Value +moreSpanData kind = + Aeson.object + [ "data2" .= (1302 :: Int) + , "data3" .= ("value3" :: String) + , "endKind" .= kind + ] + + +httpBracketApi :: + InstanaContext + -> HTTP.Manager + -> Wai.Request + -> (Wai.Response -> IO Wai.ResponseReceived) + -> IO Wai.ResponseReceived +httpBracketApi instana httpManager requestIn respond = + InstanaSDK.withHttpEntry instana requestIn "haskell.wai.server" $ do + requestOut <- + HTTP.parseUrlThrow $ + "http://127.0.0.1:1302/?some=query¶meters=2&pass=secret" + _ <- InstanaSDK.withHttpExit + instana + requestOut + (\req -> do + _ <- HTTP.httpLbs req httpManager + threadDelay $ 1000 -- make sure there is a duration > 0 + ) + respond $ + Wai.responseBuilder + HTTPTypes.status200 + [("Content-Type", "application/json; charset=UTF-8")] + "{\"response\": \"ok\"}" + + +httpLowLevelApi :: + InstanaContext + -> HTTP.Manager + -> Wai.Request + -> (Wai.Response -> IO Wai.ResponseReceived) + -> IO Wai.ResponseReceived +httpLowLevelApi instana httpManager requestIn respond = do + InstanaSDK.startHttpEntry instana requestIn "haskell.wai.server" + requestOut <- + HTTP.parseUrlThrow $ + "http://127.0.0.1:1302/?some=query¶meters=2&pass=secret" + requestOut' <- InstanaSDK.startHttpExit instana requestOut + _ <- HTTP.httpLbs requestOut' httpManager + threadDelay $ 1000 -- make sure there is a duration > 0 + InstanaSDK.completeExit instana + result <- respond $ + Wai.responseBuilder + HTTPTypes.status200 + [("Content-Type", "application/json; charset=UTF-8")] + "{\"response\": \"ok\"}" + InstanaSDK.completeEntry instana + return result + + +createSingleSpan :: + InstanaContext + -> Wai.Request + -> (Wai.Response -> IO Wai.ResponseReceived) + -> IO Wai.ResponseReceived +createSingleSpan instana requestIn respond = do + let + query = Wai.queryString requestIn + maybeMaybeSpanName = lookup ("spanName" :: ByteString) query + spanNameByteString = + Maybe.fromMaybe "haskell.test.span" $ join maybeMaybeSpanName + spanName = T.pack $ BS.unpack spanNameByteString + InstanaSDK.withRootEntry instana spanName $ do + threadDelay $ 1000 -- make sure there is a duration > 0 + respond $ + Wai.responseBuilder + HTTPTypes.status200 + [("Content-Type", "application/json; charset=UTF-8")] + "{\"response\": \"ok\"}" + + +shutDown :: + (Wai.Response -> IO Wai.ResponseReceived) + -> IO Wai.ResponseReceived +shutDown respond = do + liftIO $ infoM appLogger $ "Wai/Warp app shutdown requested" + _ <-liftIO $ Posix.exitImmediately Exit.ExitSuccess + respond $ + Wai.responseBuilder HTTPTypes.status204 [] Builder.empty + + +respondWithPlainText :: + (Wai.Response -> IO Wai.ResponseReceived) + -> String + -> IO Wai.ResponseReceived +respondWithPlainText respond content = + respond $ + Wai.responseLBS + HTTPTypes.status200 + [("Content-Type", "text/plain")] + (LBSC8.pack content) + + +respond404 :: + (Wai.Response -> IO Wai.ResponseReceived) + -> IO Wai.ResponseReceived +respond404 respond = + respond $ + Wai.responseLBS HTTPTypes.status404 [] "not found" + + +main :: IO () +main = do + initLogging + httpManager <- initHttpManager + let + config = InstanaSDK.defaultConfig { InstanaSDK.agentPort = Just 1302 } + InstanaSDK.withConfiguredInstana config $ runApp httpManager + + +runApp :: HTTP.Manager -> InstanaContext -> IO () +runApp httpManager instana = do + pid <- Posix.getProcessID + let + host = "127.0.0.1" + port = (1207 :: Int) + warpSettings = + ((Warp.setPort 1207) . (Warp.setHost "127.0.0.1")) Warp.defaultSettings + infoM appLogger $ + "Starting Wai/Warp app at " ++ host ++ ":" ++ show port ++ + " (PID: " ++ show pid ++ ")." + Warp.runSettings warpSettings $ application instana httpManager pid + + +initLogging :: IO () +initLogging = do + updateGlobalLogger appLogger $ setLevel INFO + appFileHandler <- fileHandler "wai-warp-app.log" INFO + appStreamHandler <- streamHandler stdout INFO + let + formattedAppFileHandler = withFormatter appFileHandler + formattedAppStreamHandler = withFormatter appStreamHandler + updateGlobalLogger appLogger $ + setHandlers [ formattedAppFileHandler ] + updateGlobalLogger rootLoggerName $ + setHandlers [ formattedAppStreamHandler ] + + +withFormatter :: GenericHandler Handle -> GenericHandler Handle +withFormatter handler = setFormatter handler formatter + where + timeFormat = "%F %H:%M:%S.%4q %z" + formatter = tfLogFormatter timeFormat "{$time $loggername $pid $prio} $msg" + + +initHttpManager :: IO HTTP.Manager +initHttpManager = + HTTP.newManager $ + HTTP.defaultManagerSettings + { HTTP.managerConnCount = 5 + , HTTP.managerResponseTimeout = HTTP.responseTimeoutMicro $ 5000 * 1000 + } + diff --git a/test/integration/Instana/SDK/IntegrationTest/BracketApi.hs b/test/integration/Instana/SDK/IntegrationTest/BracketApi.hs new file mode 100644 --- /dev/null +++ b/test/integration/Instana/SDK/IntegrationTest/BracketApi.hs @@ -0,0 +1,225 @@ +{-# LANGUAGE OverloadedStrings #-} +module Instana.SDK.IntegrationTest.BracketApi + ( shouldRecordSpans + , shouldRecordNonRootEntry + , shouldMergeData + ) where + + +import Data.Aeson ((.=)) +import qualified Data.Aeson as Aeson +import Data.ByteString.Lazy.Char8 as LBSC8 +import Data.Maybe (isNothing) +import qualified Network.HTTP.Client as HTTP +import Test.HUnit + +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.TestHelper as TestHelper + + +shouldRecordSpans :: String -> IO Test +shouldRecordSpans pid = + applyLabel "shouldRecordSpans" $ do + let + from = Just $ From pid + (result, spansResults) <- + TestHelper.withSpanCreation + createRootEntry + [ "haskell.dummy.root.entry" + , "haskell.dummy.exit" + ] + case spansResults of + Left failure -> + failIO $ "Could not load recorded spans from agent stub: " ++ failure + Right spans -> do + let + maybeRootEntrySpan = + TestHelper.getSpanByName "haskell.dummy.root.entry" spans + maybeExitSpan = TestHelper.getSpanByName "haskell.dummy.exit" spans + if isNothing maybeRootEntrySpan || isNothing maybeExitSpan + then + failIO "expected spans have not been recorded" + else do + let + Just rootEntrySpan = maybeRootEntrySpan + Just exitSpan = maybeExitSpan + assertAllIO + [ assertEqual "result" "exit done::entry done" result + , assertEqual "trace ID is consistent" + (TraceRequest.t exitSpan) + (TraceRequest.t rootEntrySpan) + , assertEqual "root.traceId = root.spanId" + (TraceRequest.t rootEntrySpan) + (TraceRequest.s rootEntrySpan) + , assertBool "root parent Id" $ + isNothing $ TraceRequest.p rootEntrySpan + , assertEqual "exit parent ID" + (Just $ TraceRequest.s rootEntrySpan) + (TraceRequest.p exitSpan) + , assertBool "entry timestamp" $ TraceRequest.ts rootEntrySpan > 0 + , assertBool "entry duration" $ TraceRequest.d rootEntrySpan > 0 + , assertEqual "entry kind" 1 (TraceRequest.k rootEntrySpan) + , assertEqual "entry error" 0 (TraceRequest.ec rootEntrySpan) + , assertEqual "entry from" from $ TraceRequest.f rootEntrySpan + , assertBool "exit timestamp" $ TraceRequest.ts exitSpan > 0 + , assertBool "exit duration" $ TraceRequest.d exitSpan > 0 + , assertEqual "exit kind" 2 (TraceRequest.k exitSpan) + , assertEqual "exit error" 0 (TraceRequest.ec exitSpan) + , assertEqual "exit from" from $ TraceRequest.f exitSpan + ] + + +createRootEntry :: IO String +createRootEntry = do + response <- HttpHelper.doAppRequest "bracket/api/root" "POST" [] + return $ LBSC8.unpack $ HTTP.responseBody response + + +shouldRecordNonRootEntry :: String -> IO Test +shouldRecordNonRootEntry pid = + applyLabel "shouldRecordNonRootEntry" $ do + let + from = Just $ From pid + (result, spansResults) <- + TestHelper.withSpanCreation + createNonRootEntry + [ "haskell.dummy.entry" + , "haskell.dummy.exit" + ] + case spansResults of + Left failure -> + failIO $ "Could not load recorded spans from agent stub: " ++ failure + Right spans -> do + let + maybeEntrySpan = TestHelper.getSpanByName "haskell.dummy.entry" spans + maybeExitSpan = TestHelper.getSpanByName "haskell.dummy.exit" spans + if isNothing maybeEntrySpan || isNothing maybeExitSpan + then + failIO "expected spans have not been recorded" + else do + let + Just entrySpan = maybeEntrySpan + Just exitSpan = maybeExitSpan + assertAllIO + [ assertEqual "result" "exit done::entry done" result + , assertEqual "entry trace ID" "trace-id" + (TraceRequest.t entrySpan) + , assertEqual "exit trace ID" "trace-id" (TraceRequest.t exitSpan) + , assertBool "entry span ID" $ + TraceRequest.s entrySpan /= "trace-id" + , assertBool "entry span ID" $ + TraceRequest.s entrySpan /= "parent-id" + , assertEqual "entry parent ID" + (Just "parent-id") + (TraceRequest.p entrySpan) + , assertEqual "exit parent ID" + (Just $ TraceRequest.s entrySpan) + (TraceRequest.p exitSpan) + , assertBool "entry timestamp" $ TraceRequest.ts entrySpan > 0 + , assertBool "entry duration" $ TraceRequest.d entrySpan > 0 + , assertEqual "entry kind" 1 (TraceRequest.k entrySpan) + , assertEqual "entry error" 0 (TraceRequest.ec entrySpan) + , assertEqual "entry from" from $ TraceRequest.f 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" 0 (TraceRequest.ec exitSpan) + , assertEqual "exit from" from $ TraceRequest.f exitSpan + ] + + +createNonRootEntry :: IO String +createNonRootEntry = do + response <- HttpHelper.doAppRequest "bracket/api/non-root" "POST" [] + return $ LBSC8.unpack $ HTTP.responseBody response + + +shouldMergeData :: String -> IO Test +shouldMergeData pid = + applyLabel "shouldMergeData" $ do + let + from = Just $ From pid + (result, spansResults) <- + TestHelper.withSpanCreation + createSpansWithData + [ "haskell.dummy.root.entry" + , "haskell.dummy.exit" + ] + case spansResults of + Left failure -> + failIO $ "Could not load recorded spans from agent stub: " ++ failure + Right spans -> do + let + maybeRootEntrySpan = + TestHelper.getSpanByName "haskell.dummy.root.entry" spans + maybeExitSpan = TestHelper.getSpanByName "haskell.dummy.exit" spans + if isNothing maybeRootEntrySpan || isNothing maybeExitSpan + then + failIO "expected spans have not been recorded" + else do + let + Just rootEntrySpan = maybeRootEntrySpan + Just exitSpan = maybeExitSpan + assertAllIO + [ assertEqual "result" "exit done::entry done" result + , assertEqual "trace ID is consistent" + (TraceRequest.t rootEntrySpan) + (TraceRequest.t exitSpan) + , assertEqual "root.traceId == root.spanId" + (TraceRequest.s rootEntrySpan) + (TraceRequest.t rootEntrySpan) + , assertBool "root has no parent" $ + isNothing $ TraceRequest.p rootEntrySpan + , assertEqual "exit parent" + (Just $ TraceRequest.s rootEntrySpan) + (TraceRequest.p exitSpan) + , assertBool "entry timestamp" $ TraceRequest.ts rootEntrySpan > 0 + , assertBool "entry duration" $ TraceRequest.d rootEntrySpan > 0 + , assertEqual "entry kind" 1 (TraceRequest.k rootEntrySpan) + , assertEqual "entry error" 1 (TraceRequest.ec rootEntrySpan) + , assertEqual "entry from" from $ TraceRequest.f rootEntrySpan + , assertEqual "entry data" + ( Aeson.object + [ "data1" .= ("value1" :: String) + , "data2" .= (1302 :: Int) + , "startKind" .= ("entry" :: String) + , "data2" .= (1302 :: Int) + , "data3" .= ("value3" :: String) + , "endKind" .= ("entry" :: String) + ] + ) + (TraceRequest.spanData rootEntrySpan) + , assertBool "exit timestamp" $ TraceRequest.ts exitSpan > 0 + , assertBool "exit duration" $ TraceRequest.d exitSpan > 0 + , assertEqual "exit kind" 2 (TraceRequest.k exitSpan) + , assertEqual "exit error" 2 (TraceRequest.ec exitSpan) + , assertEqual "exit from" from $ TraceRequest.f exitSpan + , assertEqual "exit data" + ( Aeson.object + [ "data1" .= ("value1" :: String) + , "data2" .= (1302 :: Int) + , "startKind" .= ("exit" :: String) + , "data2" .= (1302 :: Int) + , "data3" .= ("value3" :: String) + , "endKind" .= ("exit" :: String) + , "nested" .= (Aeson.object + [ "key1" .= ("nested.text.value1" :: String) + , "key2" .= ("nested.text.value2" :: String) + , "key3" .= (1604 :: Integer) + ] + ) + ] + ) + (TraceRequest.spanData exitSpan) + ] + + +createSpansWithData :: IO String +createSpansWithData = do + response <- HttpHelper.doAppRequest "bracket/api/with-data" "POST" [] + return $ LBSC8.unpack $ HTTP.responseBody response + diff --git a/test/integration/Instana/SDK/IntegrationTest/Connection.hs b/test/integration/Instana/SDK/IntegrationTest/Connection.hs new file mode 100644 --- /dev/null +++ b/test/integration/Instana/SDK/IntegrationTest/Connection.hs @@ -0,0 +1,216 @@ +{-# LANGUAGE OverloadedStrings #-} +module Instana.SDK.IntegrationTest.Connection + ( shouldRetryInitialConnectionEstablishment + , shouldReestablishLostConnection + , shouldReconnectAfterAgentRestart + , shouldUseTranslatedPid + , shouldUseCustomAgentName + ) where + + +import Control.Concurrent (threadDelay) +import Data.Maybe (isJust, isNothing) +import Test.HUnit + +import Instana.SDK.AgentStub.TraceRequest (From (..), Span) +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.TestHelper as TestHelper + + +shouldRetryInitialConnectionEstablishment :: String -> IO Test +shouldRetryInitialConnectionEstablishment _ = + return $ + TestLabel "shouldRetryInitialConnectionEstablishment" $ + TestCase $ + -- no actuall assertions needed, the fact that this function is executed + -- is already proof that the connection to the agent stub has been + -- established in spite of the artificial startup delay, which in turn + -- verifies that the retry mechanism for the establishing the connection + -- works + return () + + +shouldReestablishLostConnection :: String -> IO Test +shouldReestablishLostConnection _ = + applyLabel "shouldReestablishLostConnection" $ do + + -- 0 ms: send span 1 + recordSpan "haskell.dummy.connectionloss.entry-1" + threadDelay $ 2000 * 1000 + + -- 1500 ms: agent stub will switch into "connection loss simulation" mode + -- (that is, spans will be rejected) + + -- 2000 ms: send span 2, will be rejected + recordSpan "haskell.dummy.connectionloss.entry-2" + threadDelay $ 2000 * 1000 + + -- 3000 ms: span 2 will be send latest (force transmission every second) + + -- 3500 ms: agent stub will switch off "connection loss simulation" mode + + -- 4000 ms: send span 3 + recordSpan "haskell.dummy.connectionloss.entry-3" + -- wait for span 3 to arrive, check that 1 and 3 have been received + + spansResult <- TestHelper.waitForSpansMatching + [ "haskell.dummy.connectionloss.entry-3" + ] + + TestHelper.resetSpans + + case spansResult of + Left failure -> + failIO $ "Could not load recorded spans from agent stub: " ++ failure + Right spans -> do + let + maybeSpan1 = + TestHelper.getSpanByName + "haskell.dummy.connectionloss.entry-1" + spans + -- What about entry-2? Do we expect it to have been buffered and + -- resend? Do we expect it to be dropped? Right now, it is dropped. + maybeSpan2 = + TestHelper.getSpanByName + "haskell.dummy.connectionloss.entry-2" + spans + maybeSpan3 = + TestHelper.getSpanByName + "haskell.dummy.connectionloss.entry-3" + spans + if isNothing maybeSpan1 + then + failIO "expected span before connection loss has not been recorded" + else + if isNothing maybeSpan3 + then + failIO "expected span after connection loss has not been recorded" + else + return $ TestCase $ + assertBool "expected span 2 to be dropped" (isNothing maybeSpan2) + + +recordSpan :: String -> IO () +recordSpan spanName = do + _ <- + HttpHelper.doAppRequest + ("single?spanName=" ++ spanName) + "POST" + [] + return () + + +shouldReconnectAfterAgentRestart :: String -> IO Test +shouldReconnectAfterAgentRestart pid = + applyLabel "shouldReconnectAfterAgentRestart" $ do + (_, spansResultBefore) <- + TestHelper.withSpanCreation + (recordSpan "haskell.agent-restart.before-restart") + [ "haskell.agent-restart.before-restart" ] + + + -- reset discoveries, effectively simulating an agent restart + TestHelper.resetDiscoveries + + -- trigger another span, should be rejected because, from the perspective + -- of the agent stub, announce hasn't happen yet. At the same time, this + -- failure should trigger a new connection handshake between the monitored + -- process and the agent, so after loosing this span we can wait for the + -- connection handshake to happen again (and alls spans after that should be + -- processed again). + recordSpan "haskell.agent-restart.after-restart-1" + + -- wait for connection self healing + discoveries <- + TestHelper.waitForExternalAgentConnection + False + (read pid :: Int) + case discoveries of + Left message -> + assertFailure $ + "Could not establish agent connection: " ++ message + Right _ -> + verifyRecconnectAfterAgentRestart spansResultBefore + + +verifyRecconnectAfterAgentRestart :: Either String [Span] -> IO Test +verifyRecconnectAfterAgentRestart spansResultBefore = do + -- send another span, this one should be recorded again + (_, spansResultAfter) <- + TestHelper.withSpanCreation + (recordSpan "haskell.agent-restart.after-restart-2") + [ "haskell.agent-restart.after-restart-2" ] + + case (spansResultBefore, spansResultAfter) of + (Left failure1, Left failure2) -> + failIO $ "Could not load recorded spans from agent stub: " ++ + failure1 ++ "; " ++ failure2 + (Left failure, _) -> + failIO $ + "Could not load recorded spans from agent stub before " ++ + "restart: " ++ failure + (_, Left failure) -> + failIO $ + "Could not load recorded spans from agent stub after restart: " ++ + failure + (Right spansBefore, Right spansAfter) -> do + let + maybeSpanBefore = TestHelper.getSpanByName + "haskell.agent-restart.before-restart" + spansBefore + maybeSpanAfter1 = TestHelper.getSpanByName + "haskell.agent-restart.after-restart-1" + spansAfter + maybeSpanAfter2 = TestHelper.getSpanByName + "haskell.agent-restart.after-restart-2" + spansAfter + assertAllIO + [ assertBool "span has not been recorded before agent restart" $ + isJust maybeSpanBefore + , assertBool "span has not been recorded after agent restart" $ + isJust maybeSpanAfter2 + , assertBool "expected span 2 to be dropped" $ + isNothing maybeSpanAfter1 + ] + + +shouldUseTranslatedPid :: String -> IO Test +shouldUseTranslatedPid pid = do + applyLabel "shouldUseTranslatedPid" $ do + let + from = Just $ From pid + (_, spansResult) <- + TestHelper.withSpanCreation + (recordSpan "haskell.test.pid-translation") + [ "haskell.test.pid-translation" ] + case spansResult of + Left failure -> + failIO $ "Could not load recorded spans from agent stub: " ++ failure + Right spans -> do + let + maybeEntrySpan = + TestHelper.getSpanByName "haskell.test.pid-translation" spans + if isNothing maybeEntrySpan + then + failIO "expected span has not been recorded" + else do + let + Just entrySpan = maybeEntrySpan + assertAllIO $ + [ assertEqual "entry from" from $ TraceRequest.f entrySpan + ] + + +shouldUseCustomAgentName :: String -> IO Test +shouldUseCustomAgentName _ = + return $ + TestLabel "shouldUseCustomAgentName" $ + TestCase $ + -- no actuall assertions needed, the fact that this function is executed + -- is already proof that the connection to the agent stub has been + -- established in spite of the custom agent name parameter. + return () + diff --git a/test/integration/Instana/SDK/IntegrationTest/HUnitExtra.hs b/test/integration/Instana/SDK/IntegrationTest/HUnitExtra.hs new file mode 100644 --- /dev/null +++ b/test/integration/Instana/SDK/IntegrationTest/HUnitExtra.hs @@ -0,0 +1,59 @@ +module Instana.SDK.IntegrationTest.HUnitExtra + ( applyLabel + , assertAllIO + , failIO + , mergeCounts + , passIO + , skip + ) where + + +import qualified Data.List as List +import Test.HUnit + + +failIO :: String -> IO Test +failIO message = + return $ TestCase $ assertFailure message + + +passIO :: IO Test +passIO = + return $ TestCase $ assertBool "" True + + +assertAllIO :: [Assertion] -> IO Test +assertAllIO assertions = + return $ TestList $ List.map TestCase assertions + + +applyLabel :: String -> IO Test -> IO Test +applyLabel label testIO = do + t <- testIO + return $ TestLabel label t + + +skip :: String -> IO Test -> IO Test +skip label _ = do + putStrLn $ "Skipped: " ++ label + return $ TestLabel label $ TestList [] + + +mergeCounts :: [Counts] -> Counts +mergeCounts = + List.foldl + addCounts + (Counts { cases = 0, tried = 0, errors = 0, failures = 0 }) + + +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 + } + + + diff --git a/test/integration/Instana/SDK/IntegrationTest/HttpHelper.hs b/test/integration/Instana/SDK/IntegrationTest/HttpHelper.hs new file mode 100644 --- /dev/null +++ b/test/integration/Instana/SDK/IntegrationTest/HttpHelper.hs @@ -0,0 +1,225 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Instana.SDK.IntegrationTest.HttpHelper + ( agentStubHost + , agentStubPort + , agentStubUrl + , appUrl + , defaultHeaders + , doAgentStubRequest + , doAppRequest + , parseResponse + , requestAgentStubAndParse + , requestAppAndParse + , retryRequest + , retryRequestRecovering + ) where + + +import Control.Monad.Catch (Handler) +import qualified Control.Retry as Retry +import qualified Data.Aeson as Aeson +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as LBS +import qualified Network.HTTP.Client as HTTP +import Network.HTTP.Types.Header (Header, HeaderName) +import Network.HTTP.Types.Method (Method) + +import Instana.SDK.IntegrationTest.Util (putStrFlush) + + +-- 100 milliseconds +retryDelay :: Int +retryDelay = 100 * 1000 + + +-- 5 seconds +maxRetryDelay :: Int +maxRetryDelay = 5 * 1000 * 1000 + + +agentStubHost :: String +agentStubHost = "127.0.0.1" + + +agentStubPort :: Int +agentStubPort = 1302 + + +agentStubBaseUrl :: String +agentStubBaseUrl = + "http://" ++ agentStubHost ++ ":" ++ (show agentStubPort) ++ "/" + + +agentStubUrl :: String -> String +agentStubUrl path = + agentStubBaseUrl ++ path + + +appHost :: String +appHost = "127.0.0.1" + + +appPort :: Int +appPort = 1207 + + +appBaseUrl :: String +appBaseUrl = + "http://" ++ appHost ++ ":" ++ (show appPort) ++ "/" + + +appUrl :: String -> String +appUrl path = + appBaseUrl ++ path + + +defaultHeaders :: [(HeaderName, ByteString)] +defaultHeaders = + [ ("Accept", "application/json") + , ("Content-Type", "application/json; charset=UTF-8") + ] + + +requestAgentStubAndParse :: + Aeson.FromJSON a => + String + -> ByteString + -> IO (Either String a) +requestAgentStubAndParse path method = + requestAndParse path method [] agentStubUrl + + +requestAppAndParse :: + Aeson.FromJSON a => + String + -> ByteString + -> [Header] + -> IO (Either String a) +requestAppAndParse path method headers = + requestAndParse path method headers appUrl + + +doAgentStubRequest :: + String + -> Method + -> IO (HTTP.Response LBS.ByteString) +doAgentStubRequest path method = + doRequest path method [] agentStubUrl + + +doAppRequest :: + String + -> Method + -> [Header] + -> IO (HTTP.Response LBS.ByteString) +doAppRequest path method headers = + doRequest path method headers appUrl + + +requestAndParse :: + Aeson.FromJSON a => + String + -> Method + -> [Header] + -> (String -> String) + -> IO (Either String a) +requestAndParse path method headers urlCreator = do + response <- doRequest path method headers urlCreator + parseResponse response + + +doRequest :: + String + -> Method + -> [Header] + -> (String -> String) + -> IO (HTTP.Response LBS.ByteString) +doRequest path method headers urlCreator = do + httpManager <- HTTP.newManager $ + HTTP.defaultManagerSettings { HTTP.managerConnCount = 5 } + let + url = urlCreator path + defaultRequestSettings <- HTTP.parseUrlThrow url + let + request = defaultRequestSettings + { HTTP.method = method + , HTTP.requestHeaders = defaultHeaders ++ headers + } + HTTP.httpLbs request httpManager + + +parseResponse :: + Aeson.FromJSON a + => HTTP.Response LBS.ByteString + -> IO (Either String a) +parseResponse response = do + let + body = HTTP.responseBody response + parsed = Aeson.decode body + result = + case parsed of + Just p -> Right p + Nothing -> Left "Could not parse response." + return result + + +retryRequestRecovering :: + IO (HTTP.Response LBS.ByteString) + -> IO (HTTP.Response LBS.ByteString) +retryRequestRecovering request = + let + retryPolicy :: Retry.RetryPolicyM IO = + Retry.limitRetriesByCumulativeDelay maxRetryDelay $ + Retry.constantDelay retryDelay + reportHttpError :: Bool -> HTTP.HttpException -> Retry.RetryStatus -> IO () + reportHttpError _ _ _ = putStrFlush "." + retryOnAnyHttpError :: HTTP.HttpException -> IO Bool + retryOnAnyHttpError _ = return True + retryOnAnyStatus :: Retry.RetryStatus -> Handler IO Bool + retryOnAnyStatus = Retry.logRetries retryOnAnyHttpError reportHttpError + + in + Retry.recovering + retryPolicy + [retryOnAnyStatus] + (const request) + + +retryRequest :: + forall a. + Show a => + (a -> Bool) + -> IO (Either String a) + -> IO (Either String a) +retryRequest retryUntil executeRequestAndParseResponse = do + let + retryPolicy :: Retry.RetryPolicyM IO = + Retry.limitRetriesByCumulativeDelay maxRetryDelay $ + Retry.constantDelay retryDelay + retryCheck :: Retry.RetryStatus -> Either String a -> IO Bool + retryCheck _ decodedResponse = do + putStrFlush "." + case decodedResponse of + Left _ -> + return True + Right value -> + return $ not $ retryUntil value + lastResponse <- Retry.retrying + retryPolicy + retryCheck + (const executeRequestAndParseResponse) + case lastResponse of + Left _ -> + return lastResponse + Right lastValue -> + if retryUntil lastValue + then + return lastResponse + else + return $ + Left $ + "HTTP request was successful, but the expected value " ++ + "has not been obtained. The last response was: " ++ + show lastValue + diff --git a/test/integration/Instana/SDK/IntegrationTest/HttpTracing.hs b/test/integration/Instana/SDK/IntegrationTest/HttpTracing.hs new file mode 100644 --- /dev/null +++ b/test/integration/Instana/SDK/IntegrationTest/HttpTracing.hs @@ -0,0 +1,231 @@ +{-# LANGUAGE OverloadedStrings #-} +module Instana.SDK.IntegrationTest.HttpTracing + ( shouldCreateRootEntryWithBracketApi + , shouldCreateNonRootEntryWithBracketApi + , shouldSuppressWithBracketApi + , shouldCreateRootEntryWithLowLevelApi + , shouldCreateNonRootEntryWithLowLevelApi + , shouldSuppressWithLowLevelApi + ) where + + +import Control.Concurrent (threadDelay) +import Data.Aeson ((.=)) +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Lazy.Char8 as LBSC8 +import qualified Data.List as List +import Data.Maybe (isNothing) +import Instana.SDK.AgentStub.TraceRequest (From (..), Span) +import qualified Instana.SDK.AgentStub.TraceRequest as TraceRequest +import qualified Instana.SDK.IntegrationTest.HttpHelper as HttpHelper +import Instana.SDK.IntegrationTest.HUnitExtra (applyLabel, applyLabel, + assertAllIO, failIO) +import qualified Instana.SDK.IntegrationTest.TestHelper as TestHelper +import qualified Network.HTTP.Client as HTTP +import Network.HTTP.Types (Header) +import Test.HUnit + + +shouldCreateRootEntryWithBracketApi :: String -> IO Test +shouldCreateRootEntryWithBracketApi pid = + applyLabel "shouldCreateRootEntryWithBracketApi" $ + runBracketTest pid [] (applyConcat [rootEntryAsserts, bracketAsserts]) + + +shouldCreateNonRootEntryWithBracketApi :: String -> IO Test +shouldCreateNonRootEntryWithBracketApi pid = + applyLabel "shouldCreateNonRootEntryWithBracketApi" $ do + runBracketTest + pid + [ ("X-INSTANA-T", "test-trace-id") + , ("X-INSTANA-S", "test-span-id") + ] + (applyConcat [nonRootEntryAsserts, bracketAsserts]) + + +shouldSuppressWithBracketApi :: IO Test +shouldSuppressWithBracketApi = + applyLabel "shouldSuppressWithBracketApi" $ do + runSuppressedTest "http/bracket/api" + + +shouldCreateRootEntryWithLowLevelApi :: String -> IO Test +shouldCreateRootEntryWithLowLevelApi pid = + applyLabel "shouldCreateRootEntryWithLowLevelApi" $ + runLowLevelTest pid [] (applyConcat [rootEntryAsserts, lowLevelAsserts]) + + +shouldCreateNonRootEntryWithLowLevelApi :: String -> IO Test +shouldCreateNonRootEntryWithLowLevelApi pid = + applyLabel "shouldCreateNonRootEntryWithLowLevelApi" $ do + runLowLevelTest + pid + [ ("X-INSTANA-T", "test-trace-id") + , ("X-INSTANA-S", "test-span-id") + ] + (applyConcat [nonRootEntryAsserts, lowLevelAsserts]) + + +shouldSuppressWithLowLevelApi :: IO Test +shouldSuppressWithLowLevelApi = + applyLabel "shouldSuppressWithLowLevelApi" $ do + runSuppressedTest "http/low/level/api" + + +runBracketTest :: String -> [Header] -> (Span -> [Assertion]) -> IO Test +runBracketTest pid headers extraAsserts = + runTest pid "http/bracket/api?some=query¶meters=1" headers extraAsserts + + +runLowLevelTest :: String -> [Header] -> (Span -> [Assertion]) -> IO Test +runLowLevelTest pid headers extraAsserts = + runTest pid "http/low/level/api?some=query¶meters=2" headers extraAsserts + + +runTest :: String -> String -> [Header] -> (Span -> [Assertion]) -> IO Test +runTest pid urlPath headers extraAsserts = do + response <- + HttpHelper.doAppRequest urlPath "GET" headers + let + result = LBSC8.unpack $ HTTP.responseBody response + from = Just $ From pid + spansResults <- + TestHelper.waitForSpansMatching + [ "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.getSpanByName "haskell.wai.server" spans + maybeExitSpan = TestHelper.getSpanByName "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 + assertAllIO $ + (commonAsserts entrySpan exitSpan result from) ++ + (extraAsserts entrySpan) + + +runSuppressedTest :: String -> IO Test +runSuppressedTest urlPath = do + response <- + HttpHelper.doAppRequest urlPath "GET" [("X-INSTANA-L", "0")] + let + result = LBSC8.unpack $ HTTP.responseBody response + -- wait a second, then check that no spans have been recorded + threadDelay $ 10 * 1000 + spansResults <- + TestHelper.waitForSpansMatching [] + 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 + [ assertEqual "result" "{\"response\": \"ok\"}" result + ] + + +rootEntryAsserts :: Span -> [Assertion] +rootEntryAsserts entrySpan = + [ assertEqual "root.traceId = root.spanId" + (TraceRequest.t entrySpan) + (TraceRequest.s entrySpan) + , assertBool "root parent Id" $ + isNothing $ TraceRequest.p entrySpan + ] + + +nonRootEntryAsserts :: Span -> [Assertion] +nonRootEntryAsserts entrySpan = + [ assertEqual "root.traceId" + "test-trace-id" + (TraceRequest.t entrySpan) + , assertBool "root.spanId" $ + "test-trace-id" /= (TraceRequest.s entrySpan) + , assertEqual "root parent Id" + (Just $ "test-span-id") + (TraceRequest.p entrySpan) + ] + + +commonAsserts :: Span -> Span -> String -> Maybe From -> [Assertion] +commonAsserts entrySpan exitSpan result from = + [ assertEqual "result" "{\"response\": \"ok\"}" result + , assertEqual "trace ID is consistent" + (TraceRequest.t exitSpan) + (TraceRequest.t entrySpan) + , assertEqual "exit parent ID" + (Just $ TraceRequest.s entrySpan) + (TraceRequest.p exitSpan) + , assertBool "entry timestamp" $ TraceRequest.ts entrySpan > 0 + , assertBool "entry duration" $ TraceRequest.d entrySpan > 0 + , assertEqual "entry kind" 1 (TraceRequest.k entrySpan) + , assertEqual "entry error" 0 (TraceRequest.ec entrySpan) + , assertEqual "entry from" from $ TraceRequest.f 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" 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:1302/" :: String) + , "params" .= ("some=query¶meters=2" :: String) + , "status" .= (200 :: Int) + ] + ) + ] + ) + (TraceRequest.spanData exitSpan) + ] + + +bracketAsserts :: Span -> [Assertion] +bracketAsserts entrySpan = + [ assertEqual "entry data" + ( Aeson.object + [ "http" .= (Aeson.object + [ "method" .= ("GET" :: String) + , "host" .= ("127.0.0.1:1207" :: String) + , "url" .= ("/http/bracket/api" :: String) + , "params" .= ("some=query¶meters=1" :: String) + ] + ) + ] + ) + (TraceRequest.spanData entrySpan) + ] + + +lowLevelAsserts :: Span -> [Assertion] +lowLevelAsserts entrySpan = + [ assertEqual "entry data" + ( Aeson.object + [ "http" .= (Aeson.object + [ "method" .= ("GET" :: String) + , "host" .= ("127.0.0.1:1207" :: String) + , "url" .= ("/http/low/level/api" :: String) + , "params" .= ("some=query¶meters=2" :: String) + ] + ) + ] + ) + (TraceRequest.spanData entrySpan) + ] + + +applyConcat :: [a -> [b]] -> a -> [b] +applyConcat functions a = + concat $ List.map ($ a) functions + diff --git a/test/integration/Instana/SDK/IntegrationTest/LowLevelApi.hs b/test/integration/Instana/SDK/IntegrationTest/LowLevelApi.hs new file mode 100644 --- /dev/null +++ b/test/integration/Instana/SDK/IntegrationTest/LowLevelApi.hs @@ -0,0 +1,234 @@ +{-# LANGUAGE OverloadedStrings #-} +module Instana.SDK.IntegrationTest.LowLevelApi + ( shouldRecordSpans + , shouldRecordNonRootEntry + , shouldMergeData + ) where + + +import Data.Aeson ((.=)) +import qualified Data.Aeson as Aeson +import Data.ByteString.Lazy.Char8 as LBSC8 +import Data.Maybe (isNothing) +import qualified Network.HTTP.Client as HTTP +import Test.HUnit + +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.TestHelper as TestHelper + + +shouldRecordSpans :: String -> IO Test +shouldRecordSpans pid = + applyLabel "shouldRecordSpans" $ do + let + from = Just $ From pid + (result, spansResults) <- + TestHelper.withSpanCreation + createRootEntry + [ "haskell.dummy.root.entry" + , "haskell.dummy.exit" + ] + case spansResults of + Left failure -> + failIO $ "Could not load recorded spans from agent stub: " ++ failure + Right spans -> do + let + maybeRootEntrySpan = + TestHelper.getSpanByName "haskell.dummy.root.entry" spans + maybeExitSpan = TestHelper.getSpanByName "haskell.dummy.exit" spans + if isNothing maybeRootEntrySpan || isNothing maybeExitSpan + then + failIO "expected spans have not been recorded" + else do + let + Just rootEntrySpan = maybeRootEntrySpan + Just exitSpan = maybeExitSpan + assertAllIO + [ assertEqual "result" "exit done" result + , assertEqual + "trace ID is consistent" + (TraceRequest.t rootEntrySpan) + (TraceRequest.t exitSpan) + , assertEqual + "root.traceId == root.spanId" + (TraceRequest.t rootEntrySpan) + (TraceRequest.s rootEntrySpan) + , assertBool + "root has no parent ID" $ + isNothing $ TraceRequest.p rootEntrySpan + , assertEqual + "exit parent ID" + (Just $ TraceRequest.s rootEntrySpan) + (TraceRequest.p exitSpan) + , assertBool "entry timespan" $ TraceRequest.ts rootEntrySpan > 0 + , assertBool "entry duration" $ TraceRequest.d rootEntrySpan > 0 + , assertEqual "entry kind" 1 (TraceRequest.k rootEntrySpan) + , assertEqual "entry error" 0 (TraceRequest.ec rootEntrySpan) + , assertEqual "entry from" from $ TraceRequest.f rootEntrySpan + , assertBool "exit timespan" $ TraceRequest.ts exitSpan > 0 + , assertBool "exit duration" $ TraceRequest.d exitSpan > 0 + , assertEqual "exit kind" 2 (TraceRequest.k exitSpan) + , assertEqual "exit error" 0 (TraceRequest.ec exitSpan) + , assertEqual "exit from" from $ TraceRequest.f exitSpan + ] + + +createRootEntry :: IO String +createRootEntry = do + response <- HttpHelper.doAppRequest "low/level/api/root" "POST" [] + return $ LBSC8.unpack $ HTTP.responseBody response + + +shouldRecordNonRootEntry :: String -> IO Test +shouldRecordNonRootEntry pid = + applyLabel "shouldRecordNonRootEntry" $ do + let + from = Just $ From pid + (result, spansResults) <- + TestHelper.withSpanCreation + createNonRootEntry + [ "haskell.dummy.entry" + , "haskell.dummy.exit" + ] + case spansResults of + Left failure -> + failIO $ "Could not load recorded spans from agent stub: " ++ failure + Right spans -> do + let + maybeEntrySpan = + TestHelper.getSpanByName "haskell.dummy.entry" spans + maybeExitSpan = TestHelper.getSpanByName "haskell.dummy.exit" spans + if isNothing maybeEntrySpan || isNothing maybeExitSpan + then + failIO "expected spans have not been recorded" + else do + let + Just entrySpan = maybeEntrySpan + Just exitSpan = maybeExitSpan + assertAllIO + [ assertEqual "result" "exit done" result + , assertEqual "entry.traceId" "trace-id" + (TraceRequest.t entrySpan) + , assertEqual "exit.traceId" "trace-id" (TraceRequest.t exitSpan) + , assertBool "entry.spanId isn't trace ID" $ + TraceRequest.s entrySpan /= "trace-id" + , assertBool "entry.spanId isn't parent ID" $ + TraceRequest.s entrySpan /= "parent-id" + , assertEqual "entry.parentId" + (Just "parent-id") + (TraceRequest.p entrySpan) + , assertEqual "exit.parentId" + (Just $ TraceRequest.s entrySpan) + (TraceRequest.p exitSpan) + , assertBool "entry.timestamp" $ TraceRequest.ts entrySpan > 0 + , assertBool "entry.duration" $ TraceRequest.d entrySpan > 0 + , assertEqual "entry kind" 1 (TraceRequest.k entrySpan) + , assertEqual "entry error" 0 (TraceRequest.ec entrySpan) + , assertEqual "entry from" from $ TraceRequest.f 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" 0 (TraceRequest.ec exitSpan) + , assertEqual "exit from" from $ TraceRequest.f exitSpan + ] + + +createNonRootEntry :: IO String +createNonRootEntry = do + response <- HttpHelper.doAppRequest "low/level/api/non-root" "POST" [] + return $ LBSC8.unpack $ HTTP.responseBody response + + +shouldMergeData :: String -> IO Test +shouldMergeData pid = + applyLabel "shouldMergeData" $ do + let + from = Just $ From pid + (result, spansResults) <- + TestHelper.withSpanCreation + createSpansWithData + [ "haskell.dummy.root.entry" + , "haskell.dummy.exit" + ] + case spansResults of + Left failure -> + failIO $ "Could not load recorded spans from agent stub: " ++ failure + Right spans -> do + let + maybeRootEntrySpan = + TestHelper.getSpanByName "haskell.dummy.root.entry" spans + maybeExitSpan = TestHelper.getSpanByName "haskell.dummy.exit" spans + if isNothing maybeRootEntrySpan || isNothing maybeExitSpan + then + failIO "expected spans have not been recorded" + else do + let + Just rootEntrySpan = maybeRootEntrySpan + Just exitSpan = maybeExitSpan + assertAllIO + [ assertEqual "result" "exit done" result + , assertEqual "trace ID is consistent" + (TraceRequest.t exitSpan) + (TraceRequest.t rootEntrySpan) + , assertEqual "traceId == spanId" + (TraceRequest.s rootEntrySpan) + (TraceRequest.t rootEntrySpan) + , assertBool "root entry parent" $ + isNothing $ TraceRequest.p rootEntrySpan + , assertEqual "exit parent" + (Just $ TraceRequest.s rootEntrySpan) + (TraceRequest.p exitSpan) + , assertBool "entry timestamp" $ TraceRequest.ts rootEntrySpan > 0 + , assertBool "entry duration" $ TraceRequest.d rootEntrySpan > 0 + , assertEqual "entry kind" 1 (TraceRequest.k rootEntrySpan) + , assertEqual "entry error" 1 (TraceRequest.ec rootEntrySpan) + , assertEqual "entry from" from $ TraceRequest.f rootEntrySpan + , assertEqual "entry data" + ( Aeson.object + [ "data1" .= ("value1" :: String) + , "data2" .= (1302 :: Int) + , "startKind" .= ("entry" :: String) + , "data2" .= (1302 :: Int) + , "data3" .= ("value3" :: String) + , "nested" .= (Aeson.object [ + "entry" .= (Aeson.object [ + "key" .= ("nested.entry.value" :: String) + ]) + ]) + , "endKind" .= ("entry" :: String) + ] + ) + (TraceRequest.spanData rootEntrySpan) + , assertBool "exit timestamp" $ TraceRequest.ts exitSpan > 0 + , assertBool "exit duration" $ TraceRequest.d exitSpan > 0 + , assertEqual "exit kind" 2 (TraceRequest.k exitSpan) + , assertEqual "exit error" 1 (TraceRequest.ec exitSpan) + , assertEqual "exit from" from $ TraceRequest.f exitSpan + , assertEqual "exit data" + ( Aeson.object + [ "data1" .= ("value1" :: String) + , "data2" .= (1302 :: Int) + , "startKind" .= ("exit" :: String) + , "data2" .= (1302 :: Int) + , "data3" .= ("value3" :: String) + , "nested" .= (Aeson.object [ + "exit" .= (Aeson.object [ + "key" .= ("nested.exit.value" :: String) + ]) + ]) + , "endKind" .= ("exit" :: String) + ] + ) + (TraceRequest.spanData exitSpan) + ] + + +createSpansWithData :: IO String +createSpansWithData = do + response <- HttpHelper.doAppRequest "low/level/api/with-data" "POST" [] + return $ LBSC8.unpack $ HTTP.responseBody response + diff --git a/test/integration/Instana/SDK/IntegrationTest/Metrics.hs b/test/integration/Instana/SDK/IntegrationTest/Metrics.hs new file mode 100644 --- /dev/null +++ b/test/integration/Instana/SDK/IntegrationTest/Metrics.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Instana.SDK.IntegrationTest.Metrics + ( shouldReportMetrics + ) where + + +import qualified Data.Aeson as Aeson +import qualified Data.HashMap.Strict as HashMap +import qualified Data.List as List +import Data.Maybe (isJust) +import Data.Text (Text) +import qualified Data.Text as T +import Test.HUnit + +import Instana.SDK.AgentStub.EntityDataRequest (EntityDataRequest) +import qualified Instana.SDK.AgentStub.EntityDataRequest as EntityDataRequest + +import Instana.SDK.IntegrationTest.HUnitExtra (applyLabel, + assertAllIO, failIO) +import qualified Instana.SDK.IntegrationTest.TestHelper as TestHelper + + +shouldReportMetrics :: String -> IO Test +shouldReportMetrics pid = + applyLabel "shouldReportMetrics" $ do + entityDataRequestsResult <- TestHelper.waitForEntityDataWithPid pid + case entityDataRequestsResult of + Left failure -> + failIO $ + "Could not load recorded entity data requests from agent stub: " ++ + failure + Right [] -> do + failIO $ + "Could not load recorded entity data requests from agent stub " ++ + "- received empty list." + Right [entityData] -> do + assertAllIO + [ assertLabelIs "pid" pid (EntityDataRequest.pid entityData) + , assertLabelContains + "executable path" + "instana-haskell-test-wai-server" + (EntityDataRequest.executablePath entityData) + , assertLabelIs + "program name" + "instana-haskell-test-wai-server" + (EntityDataRequest.programName entityData) + , assertLabelIs + "arguments" + "" + (EntityDataRequest.arguments entityData) + , assertLabelIs + "sensorVersion" + "0.1.0.0" + (EntityDataRequest.sensorVersion entityData) + , assertCounterSatisfies + "startTime" + (1545570995405 <) + (EntityDataRequest.startTime entityData) + + , assertMetricsArePresent + "RTS GC metrics does not contain all expected metric keys" + -- The list of metrics might depend on GHC version and ekg-core + -- version, so this test is potentially fragile. If it starts to + -- make trouble, we could also just check for one well known + -- metric that is always present, should be good enough. + [ + -- Counters: + "bytes_allocated_delta" + , "num_gcs_delta" + , "num_bytes_usage_samples_delta" + , "cumulative_bytes_used_delta" + , "bytes_copied_delta" + , "mutator_cpu_ms_delta" + , "mutator_wall_ms_delta" + , "gc_cpu_ms_delta" + , "gc_wall_ms_delta" + , "cpu_ms_delta" + , "wall_ms_delta" + -- Gauges: + , "max_bytes_used" + , "current_bytes_used" + , "current_bytes_slop" + , "max_bytes_slop" + , "peak_megabytes_allocated" + , "par_tot_bytes_copied" + , "par_avg_bytes_copied" + , "par_max_bytes_copied" + ] + entityData + ] + _ -> do + failIO $ + "Unexpectedly received multiple recorded entity data requests " ++ + "from agent stub " + + +assertLabelIs :: + String + -> String + -> Maybe Text + -> Assertion +assertLabelIs testLabel expectedValue labelMetric = + assertEqual testLabel (label expectedValue) labelMetric + + +assertLabelContains :: + String + -> String + -> Maybe Text + -> Assertion +assertLabelContains testLabel expectedValue labelMetric = + if isJust labelMetric then + let + Just labelContent = labelMetric + in + assertBool testLabel (T.isInfixOf (T.pack expectedValue) labelContent) + else + assertFailure $ testLabel ++ " - label metric is Nothing" + + +label :: String -> Maybe Text +label s = + Just $ T.pack s + + +assertCounterSatisfies :: + String + -> (Int -> Bool) + -> Maybe Int + -> Assertion +assertCounterSatisfies testLabel predicate counterMetric = + case counterMetric of + Just metric -> + assertBool testLabel (predicate $ metric) + Nothing -> + assertFailure $ testLabel ++ " - counter metric is Nothing" + + +assertMetricsArePresent :: String -> [String] -> EntityDataRequest -> Assertion +assertMetricsArePresent testLabel expectedMetrics entityData = + if isJust $ EntityDataRequest.rts entityData then + let + Just rtsData = EntityDataRequest.rts entityData + gcMetricsJson = EntityDataRequest.gc rtsData + (decodingResult :: Aeson.Result Aeson.Object) = Aeson.fromJSON gcMetricsJson + in + case decodingResult of + Aeson.Error e -> + assertFailure $ testLabel ++ " - unparseable GC metrics - " ++ e + Aeson.Success decoded -> + let + containsAllMetrics = + List.foldl + (\allTrue metricKey -> + allTrue && HashMap.member (T.pack metricKey) decoded + ) + True + expectedMetrics + in + assertBool testLabel containsAllMetrics + else + assertFailure $ testLabel ++ " - no rts data" + diff --git a/test/integration/Instana/SDK/IntegrationTest/Runner.hs b/test/integration/Instana/SDK/IntegrationTest/Runner.hs new file mode 100644 --- /dev/null +++ b/test/integration/Instana/SDK/IntegrationTest/Runner.hs @@ -0,0 +1,208 @@ +{-# LANGUAGE OverloadedStrings #-} +module Instana.SDK.IntegrationTest.Runner (runSuites) where + + +import qualified Data.ByteString.Lazy.Char8 as LBSC8 +import Data.List as List +import qualified Data.Maybe as Maybe +import qualified Network.HTTP.Client as HTTP +import System.Exit as Exit +import System.Process as Process +import Test.HUnit + +import qualified Instana.SDK.IntegrationTest.HttpHelper as HttpHelper +import Instana.SDK.IntegrationTest.HUnitExtra (mergeCounts) +import Instana.SDK.IntegrationTest.Suite (ConditionalSuite (..), + Suite) +import qualified Instana.SDK.IntegrationTest.Suite as Suite +import qualified Instana.SDK.IntegrationTest.TestHelper as TestHelper +import Instana.SDK.IntegrationTest.Util (putStrFlush) + + +{-| Runs a collection of test suites. +-} +runSuites :: [ConditionalSuite] -> IO Counts +runSuites allSuites = do + let + exlusiveSuites = + List.filter Suite.isExclusive allSuites + (actions, skippedDueToExlusive) = + if not (null exlusiveSuites) then + ( List.map runConditionalSuite exlusiveSuites + , length allSuites - length exlusiveSuites + ) + else + (List.map runConditionalSuite allSuites, 0) + if not (null exlusiveSuites) then + putStrLn $ + "\n\nRunning only " ++ + show (List.length exlusiveSuites) ++ + " suite(s) marked as exclusive, ignoring all others." + else + putStrLn $ + "\n\nRunning " ++ 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 + putStrLn $ + "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 putStrLn "🎉 All tests have passed. 🎉" + return mergedResults + + +{-| Runs the suite unless it is skipped. +-} +runConditionalSuite :: ConditionalSuite -> IO Counts +runConditionalSuite conditionalSuite = do + case conditionalSuite of + Run suite -> + runSuite suite + Exclusive suite -> + runSuite suite + Skip _ -> + 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 = do + let + suiteLabel = Suite.label suite + putStrFlush $ "\nExecuting test suite: " ++ suiteLabel ++ "\n\n" + + let + options = Suite.options suite + customAgentName = Suite.customAgentName options + agentStubCommand = + (if Suite.usePidTranslation options + then "SIMULATE_PID_TRANSLATION=true " + else "" + ) ++ + (if Maybe.isJust customAgentName + then + let + Just agentName = customAgentName + in + "AGENT_NAME=\"" ++ agentName ++ "\" " + else "" + ) ++ + (if Suite.startupDelay options + then "STARTUP_DELAY=2500 " + else "" + ) ++ + (if Suite.simulateConnectionLoss options + then "SIMULATE_CONNECTION_LOSS=true " + else "" + ) + ++ "stack exec instana-haskell-agent-stub" + + appCommand = + (if Maybe.isJust customAgentName + then + let + Just agentName = customAgentName + in + "INSTANA_AGENT_NAME=\"" ++ agentName ++ "\" " + else "" + ) ++ + "INSTANA_LOG_LEVEL=INFO " ++ + "stack exec instana-haskell-test-wai-server" + + putStrLn $ "Running: " ++ agentStubCommand + Process.withCreateProcess + (Process.shell agentStubCommand) + (\_ _ _ _ -> do + putStrLn $ "Running: " ++ appCommand + Process.withCreateProcess + (Process.shell appCommand) + (\_ _ _ _ -> runTests suite) + ) + + +runTests :: Suite -> IO Counts +runTests suite = do + putStrFlush "⏱ waiting for agent stub to come up" + _ <- HttpHelper.retryRequestRecovering TestHelper.pingAgentStub + putStrLn "\n✅ agent stub is up" + putStrFlush "⏱ waiting for app to come up" + appPingResponse <- HttpHelper.retryRequestRecovering TestHelper.pingApp + let + appPingBody = HTTP.responseBody appPingResponse + appPid = (read (LBSC8.unpack appPingBody) :: Int) + putStrLn $ "\n✅ app is up, PID is " ++ (show appPid) + results <- + waitForAgentConnectionAndRun suite appPid + -- The withProcess calls that starts the agent stub and the external app + -- should also terminate them when the test suite is done or when an error + -- occurs while running the test suite. On MacOS, this works. On Linux, these + -- processes do not get terminated, for the following reasons: They are + -- started via + -- "/bin/sh -c \"stack exec ...\"" and Process.createWith will send a TERM + -- signal to terminate the started process. On Linux, this results only in the + -- "bin/sh" process to be terminated, but the "stack exec" not. Thus, the + -- first started agent stub/app instance would never be shut down. To make + -- sure the process instances get shut down, we send an extra HTTP request to + -- ask the processes to terminate themselves. + _ <- TestHelper.shutDownAgentStub + _ <- TestHelper.shutDownApp + return results + + +-- |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 appPid = do + let + options = Suite.options suite + discoveries <- + TestHelper.waitForExternalAgentConnection + (Suite.usePidTranslation options) + appPid + case discoveries of + Left message -> + assertFailure $ + "Could not start test suites " ++ (Suite.label suite) ++ + ". The agent connection could not be established: " ++ message + Right (_, pid) -> + runTestSuite pid suite + + +runTestSuite :: String -> Suite -> IO Counts +runTestSuite pid suite = do + integrationTestsIO <- wrapSuite pid suite + runTestTT integrationTestsIO + + +wrapSuite :: String -> Suite -> IO Test +wrapSuite pid suite = do + let + label = Suite.label suite + testsIO = (Suite.tests suite) pid + -- Reset the agent stub's recordeds spans after each test, but do not reset + -- the discoveries, as all tests of one suite share the connection + -- establishment process. + testsWithReset = + List.map + (\testIO -> + testIO >>= + (\testResult -> TestHelper.resetSpans >> return testResult) + ) + testsIO + -- sequence all tests into one action + tests <- sequence testsWithReset + return $ TestLabel label $ TestList tests + diff --git a/test/integration/Instana/SDK/IntegrationTest/Suite.hs b/test/integration/Instana/SDK/IntegrationTest/Suite.hs new file mode 100644 --- /dev/null +++ b/test/integration/Instana/SDK/IntegrationTest/Suite.hs @@ -0,0 +1,77 @@ +module Instana.SDK.IntegrationTest.Suite + ( ConditionalSuite(..) + , Suite(..) + , SuiteOptions(..) + , defaultOptions + , isExclusive + , withConnectionLoss + , withCustomAgentName + , withPidTranslation + , withStartupDelay + ) where + + +import Test.HUnit + + +-- |Describes a collection of cohesive tests that share the same suite options. +data Suite = + Suite + { label :: String + , tests :: String -> [IO Test] + , options :: SuiteOptions + } + + +-- |Describes options for running a test suite. +data SuiteOptions = + SuiteOptions + { usePidTranslation :: Bool + , customAgentName :: Maybe String + , startupDelay :: Bool + , simulateConnectionLoss :: Bool + } + + +defaultOptions :: SuiteOptions +defaultOptions = + SuiteOptions + { usePidTranslation = False + , customAgentName = Nothing + , startupDelay = False + , simulateConnectionLoss = False + } + + +withPidTranslation :: SuiteOptions +withPidTranslation = + defaultOptions { usePidTranslation = True } + + +withCustomAgentName :: String -> SuiteOptions +withCustomAgentName agentName = + defaultOptions { customAgentName = Just agentName } + + +withStartupDelay :: SuiteOptions +withStartupDelay = + defaultOptions { startupDelay = True } + + +withConnectionLoss :: SuiteOptions +withConnectionLoss = + defaultOptions { simulateConnectionLoss = True } + + +data ConditionalSuite = + Run Suite + | Exclusive Suite + | Skip Suite + + +isExclusive :: ConditionalSuite -> Bool +isExclusive conditionalSuite = + case conditionalSuite of + Exclusive _ -> True + _ -> False + diff --git a/test/integration/Instana/SDK/IntegrationTest/TestHelper.hs b/test/integration/Instana/SDK/IntegrationTest/TestHelper.hs new file mode 100644 --- /dev/null +++ b/test/integration/Instana/SDK/IntegrationTest/TestHelper.hs @@ -0,0 +1,284 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Instana.SDK.IntegrationTest.TestHelper + ( getSpanByName + , pingAgentStub + , pingApp + , resetDiscoveries + , resetSpans + , shutDownAgentStub + , shutDownApp + , waitForEntityDataWithPid + , waitForExternalAgentConnection + , waitForDiscoveryWithPid + , waitForAgentReadyWithPid + , waitForSpansMatching + , withSpanCreation + ) where + + +import Control.Exception (catch) +import qualified Data.ByteString.Lazy as LBS +import Data.Either (Either) +import qualified Data.List as List +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import qualified Data.Text as T +import qualified Network.HTTP.Client as HTTP + +import Instana.SDK.AgentStub.DiscoveryRequest (DiscoveryRequest) +import qualified Instana.SDK.AgentStub.DiscoveryRequest as DiscoveryRequest +import Instana.SDK.AgentStub.EntityDataRequest (EntityDataRequest) +import qualified Instana.SDK.AgentStub.EntityDataRequest as EntityDataRequest +import Instana.SDK.AgentStub.TraceRequest (Span) +import qualified Instana.SDK.AgentStub.TraceRequest as TraceRequest +import qualified Instana.SDK.IntegrationTest.HttpHelper as HttpHelper +import Instana.SDK.IntegrationTest.Util (putStrFlush, (|>)) + + +withSpanCreation :: + IO a + -> [Text] + -> IO (a, Either String [Span]) +withSpanCreation createSpanAction expectedSpans = do + result <- createSpanAction + spansResults <- waitForSpansMatching expectedSpans + resetSpans + return (result, spansResults) + + +pingAgentStub :: IO (HTTP.Response LBS.ByteString) +pingAgentStub = do + HttpHelper.doAgentStubRequest "stub/ping" "GET" + + +pingApp :: IO (HTTP.Response LBS.ByteString) +pingApp = do + HttpHelper.doAppRequest "ping" "GET" [] + + +shutDownAgentStub :: IO () +shutDownAgentStub = do + catch + ( HttpHelper.doAgentStubRequest "stub/shutdown" "POST" + >> return () + ) + -- Ignore all exceptions for the shutdown request. Either the agent stub has + -- already been shut down (so the request results in a network error) or, if + -- it is successfull, it results in an HTTP 500 because the agent stub + -- process terminates before responding. + (\ (_ :: HTTP.HttpException) -> return ()) + + +shutDownApp :: IO () +shutDownApp = do + catch + ( HttpHelper.doAppRequest "shutdown" "POST" [] + >> return () + ) + -- Ignore all exceptions for the shutdown request. Either the app has + -- already been shut down (so the request results in a network error) or, if + -- it is successfull, it results in an HTTP 500 because the app process + -- terminates before responding. + (\ (_ :: HTTP.HttpException) -> return ()) + + +waitForExternalAgentConnection :: Bool -> Int -> IO (Either String (DiscoveryRequest, String)) +waitForExternalAgentConnection = + waitForAgentConnection + + +waitForAgentConnection :: + Bool + -> Int + -> IO (Either String (DiscoveryRequest, String)) +waitForAgentConnection pidTranslation untranslatedPid = do + let + translatedPid = + if pidTranslation then untranslatedPid + 1 else untranslatedPid + pid = show translatedPid + discoveryWithPid <- waitForDiscoveryWithPid pid + case discoveryWithPid of + Left message1 -> do + putStrLn $ + "❗️ Could not establish agent connection " ++ + "(discovery failed): " ++ message1 + return $ Left $ + "❗️ Could not establish agent connection " ++ + "(discovery failed): " ++ message1 + Right _ -> do + agentReady <- waitForAgentReadyWithPid pid + case agentReady of + Left message2 -> do + putStrLn $ + "❗️ Could not establish agent connection " ++ + "(agent ready failed): " ++ message2 + return $ Left $ + "Could not establish agent connection " ++ + "(agent ready failed): " ++ message2 + Right _ -> do + putStrLn $ "\n✅ agent connection has been established" + return discoveryWithPid + + +waitForDiscoveryWithPid :: String -> IO (Either String (DiscoveryRequest, String)) +waitForDiscoveryWithPid pidStr = do + putStrFlush $ "⏱ waiting for discovery request for pid " ++ pidStr + discoveries <- + HttpHelper.retryRequest (containsDiscoveryWithPid pidStr) getDiscoveries + case discoveries of + Left message -> do + putStrLn $ "\n❗️ recorded discovery request could not be obtained" + return $ Left message + Right ds -> do + putStrLn "\n✅ recorded discovery request obtained" + return $ Right $ (head ds, pidStr) + + +getDiscoveries :: IO (Either String [DiscoveryRequest]) +getDiscoveries = do + HttpHelper.requestAgentStubAndParse "stub/discoveries" "GET" + + +containsDiscoveryWithPid :: + String + -> [DiscoveryRequest] + -> Bool +containsDiscoveryWithPid pid discoveries = + length matchingDiscoveries >= 1 + where + matchingDiscoveries = + List.filter + (\d -> DiscoveryRequest.pid d == pid) + discoveries + + +waitForAgentReadyWithPid :: String -> IO (Either String ()) +waitForAgentReadyWithPid pidStr = do + putStrFlush $ "⏱ waiting for agent ready request for pid " ++ pidStr + agentReadyPids <- + HttpHelper.retryRequest + (containsAgentReadyWithPid pidStr) + getAgentReadyPids + case agentReadyPids of + Left message -> do + putStrLn $ "\n❗️ recorded agent ready request could not be obtained" + return $ Left message + Right _ -> do + putStrLn $ "\n✅ recorded agent ready request obtained" + return $ Right () + + +getAgentReadyPids :: IO (Either String [String]) +getAgentReadyPids = do + HttpHelper.requestAgentStubAndParse "stub/agent-ready" "GET" + + +containsAgentReadyWithPid :: + String + -> [String] + -> Bool +containsAgentReadyWithPid pid pidsFromResponse = + length matchingPids > 0 + where + matchingPids = + List.filter + (\p -> p == pid) + pidsFromResponse + + +waitForEntityDataWithPid :: String -> IO (Either String [EntityDataRequest]) +waitForEntityDataWithPid pidStr = do + putStrFlush $ + "⏱ waiting for entity data for pid " ++ pidStr ++ " to be collected" + entityDataRequests <- + HttpHelper.retryRequest + (containsEntityDataRequestsWithPid pidStr) + getEntityDataRequests + case entityDataRequests of + Left message -> do + putStrLn $ "\n❗️ recorded entity data request(s) could not be obtained" + return $ Left message + Right _ -> do + putStrLn $ "\n✅ recorded entity data request(s) have been obtained" + return entityDataRequests + + +getEntityDataRequests :: IO (Either String [EntityDataRequest]) +getEntityDataRequests = do + HttpHelper.requestAgentStubAndParse "stub/entity-data" "GET" + + +containsEntityDataRequestsWithPid :: + String + -> [EntityDataRequest] + -> Bool +containsEntityDataRequestsWithPid pid entityDataRequests = + length matchingEntityDataRequests >= 1 + where + matchingEntityDataRequests = + List.filter + (\edr -> + (edr + |> EntityDataRequest.pid + |> Maybe.fromMaybe "no PID available" + |> T.unpack + ) == pid + ) + entityDataRequests + + +waitForSpansMatching :: [Text] -> IO (Either String [Span]) +waitForSpansMatching expectedNames = do + putStrFlush "⏱ waiting for spans to be processed" + spans <- HttpHelper.retryRequest (hasMatchingSpans expectedNames) getSpans + putStrLn "\n✅ spans have been processed" + return spans + + +hasMatchingSpans :: [Text] -> [Span] -> Bool +hasMatchingSpans expectedNames spans = + let + namesFromResponse = List.map TraceRequest.n spans + intersection = List.intersect namesFromResponse expectedNames + in + length intersection == length expectedNames + + +getSpans :: IO (Either String [Span]) +getSpans = + HttpHelper.requestAgentStubAndParse "stub/spans" "GET" + + +getSpanByName :: Text -> [Span] -> Maybe Span +getSpanByName name = + List.find (\s -> TraceRequest.n s == name) + + +-- |Will also reset agent ready requests and entity data requests (basically +-- forget that the announce/connection establishment has ever happened) +resetDiscoveries :: IO () +resetDiscoveries = + reset "discoveries" + + +resetSpans :: IO () +resetSpans = + reset "spans" + + +reset :: String -> IO () +reset what = do + httpManager <- HTTP.newManager $ + HTTP.defaultManagerSettings { HTTP.managerConnCount = 5 } + let + url = HttpHelper.agentStubUrl $ "stub/reset/" ++ what + defaultRequestSettings <- HTTP.parseUrlThrow url + let + request = defaultRequestSettings + { HTTP.method = "POST" + , HTTP.requestHeaders = HttpHelper.defaultHeaders + } + _ <- HTTP.httpLbs request httpManager + return () + diff --git a/test/integration/Instana/SDK/IntegrationTest/TestSuites.hs b/test/integration/Instana/SDK/IntegrationTest/TestSuites.hs new file mode 100644 --- /dev/null +++ b/test/integration/Instana/SDK/IntegrationTest/TestSuites.hs @@ -0,0 +1,143 @@ +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 Instana.SDK.IntegrationTest.Suite (ConditionalSuite (..), + Suite (..)) +import qualified Instana.SDK.IntegrationTest.Suite as Suite + + +allSuites :: [ConditionalSuite] +allSuites = + [ testBracketApi + , testLowLevelApi + , testConnectionEstablishment + , testConnectionLoss + , testAgentRestart + , testPidTranslation + , testCustomAgentName + , testHttpTracing + , testMetrics + ] + + +testBracketApi :: ConditionalSuite +testBracketApi = + Run $ + Suite + { Suite.label = "Bracket API" + , Suite.tests = (\pid -> + [ BracketApi.shouldRecordSpans pid + , BracketApi.shouldRecordNonRootEntry pid + , BracketApi.shouldMergeData pid + ]) + , Suite.options = Suite.defaultOptions + } + + +testLowLevelApi :: ConditionalSuite +testLowLevelApi = + Run $ + Suite + { Suite.label = "Low Level API" + , Suite.tests = (\pid -> + [ LowLevelApi.shouldRecordSpans pid + , LowLevelApi.shouldRecordNonRootEntry pid + , LowLevelApi.shouldMergeData pid + ]) + , Suite.options = Suite.defaultOptions + } + + +testConnectionEstablishment :: ConditionalSuite +testConnectionEstablishment = + Run $ + Suite + { Suite.label = "Initial Connection Establishment" + , Suite.tests = (\pid -> [ + Connection.shouldRetryInitialConnectionEstablishment pid + ]) + , Suite.options = Suite.withStartupDelay + } + + +testConnectionLoss :: ConditionalSuite +testConnectionLoss = + Run $ + Suite + { Suite.label = "Connection Loss" + , Suite.tests = (\pid -> [ + Connection.shouldReestablishLostConnection pid + ]) + , Suite.options = Suite.withConnectionLoss + } + + +testAgentRestart :: ConditionalSuite +testAgentRestart = + Run $ + Suite + { Suite.label = "Agent Restart" + , Suite.tests = (\pid -> [ + Connection.shouldReconnectAfterAgentRestart pid + ]) + , Suite.options = Suite.defaultOptions + } + + +testPidTranslation :: ConditionalSuite +testPidTranslation = + Run $ + Suite + { Suite.label = "PID translation" + , Suite.tests = (\pid -> [ + Connection.shouldUseTranslatedPid pid + ]) + , Suite.options = Suite.withPidTranslation + } + + +testCustomAgentName :: ConditionalSuite +testCustomAgentName = + Run $ + Suite + { Suite.label = "Custom Agent Name" + , Suite.tests = (\pid -> [ + Connection.shouldUseCustomAgentName pid + ]) + , Suite.options = Suite.withCustomAgentName "Devil in Disguise" + } + + +testHttpTracing :: ConditionalSuite +testHttpTracing = + Run $ + Suite + { Suite.label = "HTTP Tracing" + , Suite.tests = (\pid -> [ + HttpTracing.shouldCreateRootEntryWithBracketApi pid + , HttpTracing.shouldCreateNonRootEntryWithBracketApi pid + , HttpTracing.shouldSuppressWithBracketApi + , HttpTracing.shouldCreateRootEntryWithLowLevelApi pid + , HttpTracing.shouldCreateNonRootEntryWithLowLevelApi pid + , HttpTracing.shouldSuppressWithLowLevelApi + ]) + , Suite.options = Suite.defaultOptions + } + + +testMetrics :: ConditionalSuite +testMetrics = + Run $ + Suite + { Suite.label = "Metrics" + , Suite.tests = (\pid -> [ + Metrics.shouldReportMetrics pid + ]) + , Suite.options = Suite.withPidTranslation + } + diff --git a/test/integration/Instana/SDK/IntegrationTest/Util.hs b/test/integration/Instana/SDK/IntegrationTest/Util.hs new file mode 100644 --- /dev/null +++ b/test/integration/Instana/SDK/IntegrationTest/Util.hs @@ -0,0 +1,19 @@ +module Instana.SDK.IntegrationTest.Util + ( (|>) + , putStrFlush + ) where + + +import System.IO (hFlush, stdout) + + +(|>) :: a -> (a -> b) -> b +(|>) = + flip ($) + + +putStrFlush :: String -> IO () +putStrFlush s = do + putStr s + hFlush stdout + diff --git a/test/integration/Main.hs b/test/integration/Main.hs new file mode 100644 --- /dev/null +++ b/test/integration/Main.hs @@ -0,0 +1,13 @@ +module Main where + + +import Test.HUnit + +import qualified Instana.SDK.IntegrationTest.Runner as TestRunner +import qualified Instana.SDK.IntegrationTest.TestSuites as TestSuites + + +main :: IO Counts +main = + TestRunner.runSuites TestSuites.allSuites + diff --git a/test/shared/Instana/SDK/AgentStub/DiscoveryRequest.hs b/test/shared/Instana/SDK/AgentStub/DiscoveryRequest.hs new file mode 100644 --- /dev/null +++ b/test/shared/Instana/SDK/AgentStub/DiscoveryRequest.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE DeriveGeneric #-} +module Instana.SDK.AgentStub.DiscoveryRequest where + + +import Data.Aeson +import GHC.Generics + + +data DiscoveryRequest = + DiscoveryRequest + { pid :: String + , progName :: String + , execPath :: String + , args :: [String] + } deriving (Eq, Show, Generic) + + +instance FromJSON DiscoveryRequest +instance ToJSON DiscoveryRequest + diff --git a/test/shared/Instana/SDK/AgentStub/DiscoveryResponse.hs b/test/shared/Instana/SDK/AgentStub/DiscoveryResponse.hs new file mode 100644 --- /dev/null +++ b/test/shared/Instana/SDK/AgentStub/DiscoveryResponse.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE DeriveGeneric #-} +module Instana.SDK.AgentStub.DiscoveryResponse where + +import Data.Aeson +import Data.Text (Text) +import GHC.Generics + + +data DiscoveryResponse = + DiscoveryResponse + { pid :: Int + , agentUuid :: Text + , extraHeaders :: Maybe [Text] + , secrets :: SecretsConfig + } deriving (Eq, Show, Generic) + +instance ToJSON DiscoveryResponse + + +data SecretsConfig = SecretsConfig + { matcher :: Text + , list :: [Text] + } deriving (Eq, Show, Generic) + +instance ToJSON SecretsConfig + diff --git a/test/shared/Instana/SDK/AgentStub/EntityDataRequest.hs b/test/shared/Instana/SDK/AgentStub/EntityDataRequest.hs new file mode 100644 --- /dev/null +++ b/test/shared/Instana/SDK/AgentStub/EntityDataRequest.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE DeriveGeneric #-} +module Instana.SDK.AgentStub.EntityDataRequest where + + +import Data.Aeson +import qualified Data.Aeson as Aeson +import Data.Text (Text) +import GHC.Generics + + +-- Example entity data JSON: +-- { +-- "executablePath": "/opt/very/important/service/bin/exec", +-- "arguments": "" +-- "programName": "instana-haskell-trace-sdk-integration-tests" +-- "pid": "30114" +-- "sensorVersion": "0.1.0.0" +-- "startTime": 1545569786526 +-- "rts": { +-- "gc": { +-- "gc_cpu_ms": 35 +-- "mutator_wall_ms": 8743 +-- "mutator_cpu_ms": 155 +-- "gc_wall_ms": 8 +-- "wall_ms": 8751 +-- "bytes_copied": 2225552 +-- "max_bytes_used": 2279960 +-- "max_bytes_slop": 110376 +-- "num_bytes_usage_samples": 3 +-- "peak_megabytes_allocated": 12 +-- "cpu_ms": 190 +-- "current_bytes_used": 3151432 +-- "bytes_allocated": 122542896 +-- "par_max_bytes_copied": 1311424 +-- "current_bytes_slop": 96696 +-- "cumulative_bytes_used": 3993064 +-- "num_gcs": 31 +-- "par_tot_bytes_copied": 2225552 +-- "par_avg_bytes_copied": 2225552 +-- } +-- } +-- } + + +data EntityDataRequest = + EntityDataRequest + { pid :: Maybe Text + , executablePath :: Maybe Text + -- arguments are concatenated, separate by one space character + , arguments :: Maybe Text + , programName :: Maybe Text + , startTime :: Maybe Int + , sensorVersion :: Maybe Text + , rts :: Maybe RtsData + } deriving (Eq, Show, Generic) + + +instance FromJSON EntityDataRequest +instance ToJSON EntityDataRequest + + +data RtsData = + RtsData + { gc :: Aeson.Value + } deriving (Eq, Show, Generic) + + +instance FromJSON RtsData +instance ToJSON RtsData + diff --git a/test/shared/Instana/SDK/AgentStub/TraceRequest.hs b/test/shared/Instana/SDK/AgentStub/TraceRequest.hs new file mode 100644 --- /dev/null +++ b/test/shared/Instana/SDK/AgentStub/TraceRequest.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE OverloadedStrings #-} +module Instana.SDK.AgentStub.TraceRequest where + + +import Data.Aeson (FromJSON, ToJSON, Value, (.:), (.=)) +import qualified Data.Aeson as Aeson +import Data.Text (Text) +import GHC.Generics + + +type TraceRequest = [Span] + + +data From = From + { entityId :: String + } deriving (Eq, Generic, Show) + + +instance FromJSON From where + parseJSON = Aeson.withObject "from" $ + \fr -> + From + <$> fr .: "e" -- entityId + + +instance ToJSON From where + toJSON :: From -> Value + toJSON fr = Aeson.object + [ "e" .= entityId fr ] + + +data Span = + Span + { t :: String -- traceId + , s :: String -- spanId + , p :: Maybe String -- parentId + , n :: Text -- spanName + , ts :: Int -- timestamp + , d :: Int -- duration + , k :: Int -- kind + , ec :: Int -- errorCount + , spanData :: Aeson.Value -- spanData + , f :: Maybe From -- from + } deriving (Eq, Show, Generic) + + +instance FromJSON Span where + parseJSON = Aeson.withObject "span" $ + \decodedObject -> + Span + <$> decodedObject .: "t" + <*> decodedObject .: "s" + <*> decodedObject .: "p" + <*> decodedObject .: "n" + <*> decodedObject .: "ts" + <*> decodedObject .: "d" + <*> decodedObject .: "k" + <*> decodedObject .: "ec" + <*> decodedObject .: "data" + <*> decodedObject .: "f" + + +instance ToJSON Span where + toJSON sp = Aeson.object + [ "t" .= t sp + , "s" .= s sp + , "p" .= p sp + , "n" .= n sp + , "ts" .= ts sp + , "d" .= d sp + , "k" .= k sp + , "ec" .= ec sp + , "data" .= spanData sp + , "f" .= f sp + ] + diff --git a/test/unit/Instana/SDK/Internal/AgentConnection/SchedFileTest.hs b/test/unit/Instana/SDK/Internal/AgentConnection/SchedFileTest.hs new file mode 100644 --- /dev/null +++ b/test/unit/Instana/SDK/Internal/AgentConnection/SchedFileTest.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +module Instana.SDK.Internal.AgentConnection.SchedFileTest (allTests) where + + +import Test.HUnit + +import Instana.SDK.Internal.AgentConnection.SchedFile (parsePidFromSchedFile) + + +allTests :: Test +allTests = + TestList + [ TestLabel "shouldParsePidFromSchedFile" shouldParsePidFromSchedFile + , TestLabel "shouldReturnNothingIfNoMatch" shouldReturnNothingIfNoMatch + , TestLabel "shouldReturnNothingIfEmptyFile" shouldReturnNothingIfEmptyFile + ] + + +shouldParsePidFromSchedFile :: Test +shouldParsePidFromSchedFile = + let + parsedPid = parsePidFromSchedFile schedFileContent + in + TestCase $ + assertEqual "parsed PID" (Just "22651") parsedPid + + +shouldReturnNothingIfNoMatch :: Test +shouldReturnNothingIfNoMatch = + let + parsedPid = parsePidFromSchedFile schedFileNoMatch + in + TestCase $ + assertEqual "parsed PID" Nothing parsedPid + + +shouldReturnNothingIfEmptyFile :: Test +shouldReturnNothingIfEmptyFile = + let + parsedPid = parsePidFromSchedFile "" + in + TestCase $ + assertEqual "parsed PID" Nothing parsedPid + + +schedFileContent :: String +schedFileContent = + "apache2 (22651, #threads: 1)" ++ + "-------------------------------------------------------------------" ++ + "se.exec_start : 321880170.687098" ++ + "se.vruntime : 817.197081" ++ + "se.sum_exec_runtime : 4167.723920" ++ + "se.statistics.sum_sleep_runtime : 115543541.232258" ++ + "se.statistics.wait_start : 0.000000" ++ + "se.statistics.sleep_start : 321880170.687098" ++ + "se.statistics.block_start : 0.000000" ++ + "se.statistics.sleep_max : 1008.728760" ++ + "se.statistics.block_max : 3613.503856" ++ + "se.statistics.exec_max : 4.019296" ++ + "se.statistics.slice_max : 4.121777" ++ + "se.statistics.wait_max : 16.121293" ++ + "se.statistics.wait_sum : 614.212315" ++ + "se.statistics.wait_count : 116171" ++ + "se.statistics.iowait_sum : 5.531804" ++ + "se.statistics.iowait_count : 10" ++ + "se.nr_migrations : 24284" ++ + "se.statistics.nr_migrations_cold : 0" ++ + "se.statistics.nr_failed_migrations_affine : 0" ++ + "se.statistics.nr_failed_migrations_running : 744" ++ + "se.statistics.nr_failed_migrations_hot : 40" ++ + "se.statistics.nr_forced_migrations : 4" ++ + "se.statistics.nr_wakeups : 115512" ++ + "se.statistics.nr_wakeups_sync : 21" ++ + "se.statistics.nr_wakeups_migrate : 23773" ++ + "se.statistics.nr_wakeups_local : 91682" ++ + "se.statistics.nr_wakeups_remote : 23830" ++ + "se.statistics.nr_wakeups_affine : 71" ++ + "se.statistics.nr_wakeups_affine_attempts : 80" ++ + "se.statistics.nr_wakeups_passive : 0" ++ + "se.statistics.nr_wakeups_idle : 0" ++ + "avg_atom : 0.036034" ++ + "avg_per_cpu : 0.171624" ++ + "nr_switches : 115660" ++ + "nr_voluntary_switches : 115513" ++ + "nr_involuntary_switches : 147" ++ + "se.load.weight : 1024" ++ + "se.avg.load_sum : 26624" ++ + "se.avg.util_sum : 26624" ++ + "se.avg.load_avg : 0" ++ + "se.avg.util_avg : 0" ++ + "se.avg.last_update_time : 321880170687098" ++ + "policy : 0" ++ + "prio : 120" ++ + "clock-delta : 29" ++ + "mm->numa_scan_seq : 0" ++ + "numa_pages_migrated : 0" ++ + "numa_preferred_nid : -1" ++ + "total_numa_faults : 0" ++ + "current_node=0, numa_group_id=0" ++ + "numa_faults node=0 task_private=0 task_shared=0 group_private=0 group_shared=0" + + +schedFileNoMatch :: String +schedFileNoMatch = + "-------------------------------------------------------------------" ++ + "se.exec_start : 321880170.687098" ++ + "se.vruntime : 817.197081" ++ + "se.sum_exec_runtime : 4167.723920" ++ + "se.statistics.sum_sleep_runtime : 115543541.232258" ++ + "se.statistics.wait_start : 0.000000" ++ + "se.statistics.sleep_start : 321880170.687098" ++ + "se.statistics.block_start : 0.000000" ++ + "se.statistics.sleep_max : 1008.728760" ++ + "se.statistics.block_max : 3613.503856" ++ + "se.statistics.exec_max : 4.019296" ++ + "se.statistics.slice_max : 4.121777" ++ + "se.statistics.wait_max : 16.121293" ++ + "se.statistics.wait_sum : 614.212315" ++ + "se.statistics.wait_count : 116171" ++ + "se.statistics.iowait_sum : 5.531804" ++ + "se.statistics.iowait_count : 10" ++ + "se.nr_migrations : 24284" ++ + "se.statistics.nr_migrations_cold : 0" ++ + "se.statistics.nr_failed_migrations_affine : 0" ++ + "se.statistics.nr_failed_migrations_running : 744" ++ + "se.statistics.nr_failed_migrations_hot : 40" ++ + "se.statistics.nr_forced_migrations : 4" ++ + "se.statistics.nr_wakeups : 115512" ++ + "se.statistics.nr_wakeups_sync : 21" ++ + "se.statistics.nr_wakeups_migrate : 23773" ++ + "se.statistics.nr_wakeups_local : 91682" ++ + "se.statistics.nr_wakeups_remote : 23830" ++ + "se.statistics.nr_wakeups_affine : 71" ++ + "se.statistics.nr_wakeups_affine_attempts : 80" ++ + "se.statistics.nr_wakeups_passive : 0" ++ + "se.statistics.nr_wakeups_idle : 0" ++ + "avg_atom : 0.036034" ++ + "avg_per_cpu : 0.171624" ++ + "nr_switches : 115660" ++ + "nr_voluntary_switches : 115513" ++ + "nr_involuntary_switches : 147" ++ + "se.load.weight : 1024" ++ + "se.avg.load_sum : 26624" ++ + "se.avg.util_sum : 26624" ++ + "se.avg.load_avg : 0" ++ + "se.avg.util_avg : 0" ++ + "se.avg.last_update_time : 321880170687098" ++ + "policy : 0" ++ + "prio : 120" ++ + "clock-delta : 29" ++ + "mm->numa_scan_seq : 0" ++ + "numa_pages_migrated : 0" ++ + "numa_preferred_nid : -1" ++ + "total_numa_faults : 0" ++ + "current_node=0, numa_group_id=0" ++ + "numa_faults node=0 task_private=0 task_shared=0 group_private=0 group_shared=0" diff --git a/test/unit/Instana/SDK/Internal/ConfigTest.hs b/test/unit/Instana/SDK/Internal/ConfigTest.hs new file mode 100644 --- /dev/null +++ b/test/unit/Instana/SDK/Internal/ConfigTest.hs @@ -0,0 +1,138 @@ +module Instana.SDK.Internal.ConfigTest (allTests) where + + +import Data.Maybe (isNothing) +import System.Environment (setEnv, unsetEnv) +import Test.HUnit + +import Instana.SDK.Config (Config) +import qualified Instana.SDK.Config as Config +import qualified Instana.SDK.Internal.Config as InternalConfig + + +allTests :: Test +allTests = + TestList + [ TestLabel "mergeShouldApplyDefaults" mergeShouldApplyDefaults + , TestLabel "mergeShouldPreferFirstArg" mergeShouldPreferFirstArg + , TestLabel + "shouldReadNonExistingEnvironmentVariablesAsNothing" + shouldReadNonExistingEnvironmentVariablesAsNothing + , TestLabel + "shouldReadExistingEnvironmentVariables" + shouldReadExistingEnvironmentVariables + , TestLabel + "shouldReadNonNumericPortAsNothing" + shouldReadNonNumericPortAsNothing + , TestLabel + "shouldReadNonExistingEnvVarsAndApplyDefaults" + shouldReadNonExistingEnvVarsAndApplyDefaults + ] + + +mergeShouldApplyDefaults :: Test +mergeShouldApplyDefaults = + let + merged = InternalConfig.mergeConfigs emptyConfig emptyConfig + in + TestList $ + [ TestCase $ + assertEqual + "agent host" "127.0.0.1" (InternalConfig.agentHost merged) + , TestCase $ + assertEqual "agent port" 42699 (InternalConfig.agentPort merged) + , TestCase $ + assertEqual + "agent name" + "Instana Agent" + (InternalConfig.agentName merged) + ] + + +mergeShouldPreferFirstArg :: Test +mergeShouldPreferFirstArg = + let + first = + Config.defaultConfig + { Config.agentHost = Just "horst" + , Config.agentPort = Just 12345 + , Config.agentName = Just "Hans" + } + second = + Config.defaultConfig + { Config.agentHost = Just "wurst" + , Config.agentPort = Just 98765 + , Config.agentName = Just "Franz" + } + merged = InternalConfig.mergeConfigs first second + in + TestList $ + [ TestCase $ + assertEqual + "agent host" "horst" (InternalConfig.agentHost merged) + , TestCase $ + assertEqual "agent port" 12345 (InternalConfig.agentPort merged) + , TestCase $ + assertEqual + "agent name" + "Hans" + (InternalConfig.agentName merged) + ] + + +shouldReadNonExistingEnvironmentVariablesAsNothing :: Test +shouldReadNonExistingEnvironmentVariablesAsNothing = + TestCase $ + do + conf <- InternalConfig.readConfigFromEnvironment + assertBool "agent host" (isNothing $ Config.agentHost conf) + assertBool "agent port" (isNothing $ Config.agentPort conf) + assertBool "agent name" (isNothing $ Config.agentName conf) + + +shouldReadExistingEnvironmentVariables :: Test +shouldReadExistingEnvironmentVariables = + TestCase $ + do + setEnv "INSTANA_AGENT_HOST" "agenthost.com" + setEnv "INSTANA_AGENT_PORT" "12345" + setEnv "INSTANA_AGENT_NAME" "Say my name, say my name" + conf <- InternalConfig.readConfigFromEnvironment + assertEqual "agent host" (Just "agenthost.com") (Config.agentHost conf) + assertEqual "agent port" (Just 12345) (Config.agentPort conf) + assertEqual + "agent name" + (Just "Say my name, say my name") + (Config.agentName conf) + unsetEnv "INSTANA_AGENT_HOST" + unsetEnv "INSTANA_AGENT_PORT" + unsetEnv "INSTANA_AGENT_NAME" + + +shouldReadNonNumericPortAsNothing :: Test +shouldReadNonNumericPortAsNothing = + TestCase $ + do + setEnv "INSTANA_AGENT_PORT" "12x45" + conf <- InternalConfig.readConfigFromEnvironment + assertBool "agent port" $ isNothing $ Config.agentPort conf + unsetEnv "INSTANA_AGENT_PORT" + + +shouldReadNonExistingEnvVarsAndApplyDefaults :: Test +shouldReadNonExistingEnvVarsAndApplyDefaults = + TestCase $ + do + conf <- InternalConfig.readConfigFromEnvironmentAndApplyDefaults + assertEqual "agent host" "127.0.0.1" (InternalConfig.agentHost conf) + assertEqual "agent port" 42699 (InternalConfig.agentPort conf) + assertEqual + "agent name" + "Instana Agent" + (InternalConfig.agentName conf) + + +emptyConfig :: Config +emptyConfig = + Config.defaultConfig + diff --git a/test/unit/Instana/SDK/Internal/IdTest.hs b/test/unit/Instana/SDK/Internal/IdTest.hs new file mode 100644 --- /dev/null +++ b/test/unit/Instana/SDK/Internal/IdTest.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Instana.SDK.Internal.IdTest (allTests) where + + +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Lazy.Char8 as BS +import Test.HUnit + +import Instana.SDK.Internal.Id (Id) +import qualified Instana.SDK.Internal.Id as Id + + +allTests :: Test +allTests = + TestList + [ TestLabel "shouldEncodeIntComponents" shouldEncodeIntComponents + , TestLabel "shouldEncodeIntComponents2" shouldEncodeIntComponents2 + , TestLabel "shouldEncodeStringId" shouldEncodeStringId + , TestLabel "shouldDecodeStringId " shouldDecodeStringId + , TestLabel "shouldGenerate" shouldGenerate + ] + + +shouldEncodeIntComponents :: Test +shouldEncodeIntComponents = + let + idFromInts = Id.createFromIntsForTest [12345, 67890] + encoded = BS.unpack . Aeson.encode $ idFromInts + in + TestCase $ + assertEqual "encoded" "\"0000303900010932\"" encoded + + +shouldEncodeIntComponents2 :: Test +shouldEncodeIntComponents2 = + let + -- minimum for Int type as per + -- http://hackage.haskell.org/package/base-4.11.1.0/docs/Data-Int.html + -- is from -2^29 to 29-1 -> -536870912 to 536870911 + idFromInts = Id.createFromIntsForTest [-536870912, 536870911] + encoded = BS.unpack . Aeson.encode $ idFromInts + in + TestCase $ + assertEqual "encoded" "\"200000001fffffff\"" encoded + + +shouldEncodeStringId :: Test +shouldEncodeStringId = + let + idFromString = Id.fromString "some string" + encoded = BS.unpack . Aeson.encode $ idFromString + in + TestCase $ + assertEqual "encoded" "\"some string\"" encoded + + +shouldDecodeStringId :: Test +shouldDecodeStringId = + let + expected = Id.fromString "some string" + maybeId = Aeson.decode (BS.pack "\"some string\"") :: Maybe Id + Just decoded = maybeId + in + TestCase $ assertEqual "decoded" expected decoded + + +shouldGenerate :: Test +shouldGenerate = + TestCase $ + do + generated <- Id.generate + let + encoded = BS.unpack . Aeson.encode $ generated + -- every encoded ID must be 16 chars wide + 2 chars for leading and + -- trailing " + assertEqual "generated" 18 (length encoded) + diff --git a/test/unit/Instana/SDK/Internal/LoggingTest.hs b/test/unit/Instana/SDK/Internal/LoggingTest.hs new file mode 100644 --- /dev/null +++ b/test/unit/Instana/SDK/Internal/LoggingTest.hs @@ -0,0 +1,154 @@ +module Instana.SDK.Internal.LoggingTest (allTests) where + + +import Data.Maybe (isNothing) +import System.Log.Logger (Priority (..)) +import Test.HUnit + +import qualified Instana.SDK.Internal.Logging as Logging + + +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 "shouldParseEmpty" shouldParseEmpty + , TestLabel "shouldParseInvalid" shouldParseInvalid + , TestLabel "minOfTwoNothings" minOfTwoNothings + , TestLabel "minRightJust" minRightJust + , TestLabel "minLeftJust" minLeftJust + , TestLabel "minDebugWarning" minDebugWarning + , TestLabel "minWarningDebug" minWarningDebug + ] + + +shouldParseDebug :: Test +shouldParseDebug = + let + parsed = Logging.parseLogLevel "DEBUG" + in + TestCase $ assertEqual "parsed level" (Just DEBUG) parsed + + +shouldParseInfo :: Test +shouldParseInfo = + let + parsed = Logging.parseLogLevel "INFO" + in + TestCase $ assertEqual "parsed level" (Just INFO) parsed + + +shouldParseNotice :: Test +shouldParseNotice = + let + parsed = Logging.parseLogLevel "NOTICE" + in + TestCase $ assertEqual "parsed level" (Just NOTICE) parsed + + +shouldParseWarning :: Test +shouldParseWarning = + let + parsed = Logging.parseLogLevel "WARNING" + in + TestCase $ assertEqual "parsed level" (Just WARNING) parsed + + +shouldParseError :: Test +shouldParseError = + let + parsed = Logging.parseLogLevel "ERROR" + in + TestCase $ assertEqual "parsed level" (Just ERROR) parsed + + +shouldParseCritical :: Test +shouldParseCritical = + let + parsed = Logging.parseLogLevel "CRITICAL" + in + TestCase $ assertEqual "parsed level" (Just CRITICAL) parsed + + +shouldParseAlert :: Test +shouldParseAlert = + let + parsed = Logging.parseLogLevel "ALERT" + in + TestCase $ assertEqual "parsed level" (Just ALERT) parsed + + +shouldParseEmergency :: Test +shouldParseEmergency = + let + parsed = Logging.parseLogLevel "EMERGENCY" + in + TestCase $ assertEqual "parsed level" (Just EMERGENCY) parsed + + +shouldParseEmpty :: Test +shouldParseEmpty = + let + parsed = Logging.parseLogLevel "" + in + TestCase $ assertBool "parsed level" (isNothing parsed) + + +shouldParseInvalid :: Test +shouldParseInvalid = + let + parsed = Logging.parseLogLevel "invalid" + in + TestCase $ assertBool "parsed level" (isNothing parsed) + + +minOfTwoNothings :: Test +minOfTwoNothings = + TestCase $ + assertBool + "parsed level" + (isNothing $ Logging.minimumLogLevel Nothing Nothing) + + +minRightJust :: Test +minRightJust = + TestCase $ + assertEqual + "min" + (Just DEBUG) + (Logging.minimumLogLevel Nothing (Just DEBUG)) + + +minLeftJust :: Test +minLeftJust = + TestCase $ + assertEqual + "min" + (Just WARNING) + (Logging.minimumLogLevel (Just WARNING) Nothing) + + +minDebugWarning :: Test +minDebugWarning = + TestCase $ + assertEqual + "min" + (Just DEBUG) + (Logging.minimumLogLevel (Just WARNING) (Just DEBUG)) + + +minWarningDebug :: Test +minWarningDebug = + TestCase $ + assertEqual + "min" + (Just DEBUG) + (Logging.minimumLogLevel (Just DEBUG) (Just WARNING)) + diff --git a/test/unit/Instana/SDK/Internal/Metrics/CompressionTest.hs b/test/unit/Instana/SDK/Internal/Metrics/CompressionTest.hs new file mode 100644 --- /dev/null +++ b/test/unit/Instana/SDK/Internal/Metrics/CompressionTest.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE OverloadedStrings #-} +module Instana.SDK.Internal.Metrics.CompressionTest (allTests) where + + +import qualified Data.HashMap.Strict as HashMap +import Test.HUnit + +import qualified Instana.SDK.Internal.Metrics.Compression as MetricsCompression +import Instana.SDK.Internal.Metrics.Sample (InstanaMetricValue (..)) + + +allTests :: Test +allTests = + TestList + [ TestLabel "shouldNotRemoveNewMetrics" shouldNotRemoveNewMetrics + , TestLabel "shouldNotRemoveChangedMetrics" shouldNotRemoveChangedMetrics + , TestLabel "shouldRemoveUnchangedMetrics" shouldRemoveUnchangedMetrics + , TestLabel "shouldLeaveChangedUntouched" shouldLeaveChangedUntouched + ] + + +shouldNotRemoveNewMetrics :: Test +shouldNotRemoveNewMetrics = + let + previous = + HashMap.empty + next = + HashMap.singleton "key" (StringValue "value") + compressed = + MetricsCompression.compressSample previous next + in + TestCase $ + assertEqual + "don't remove new" + (Just $ StringValue "value") + (HashMap.lookup "key" compressed) + + +shouldNotRemoveChangedMetrics :: Test +shouldNotRemoveChangedMetrics = + let + previous = + HashMap.singleton "key" (StringValue "value 1") + next = + HashMap.singleton "key" (StringValue "value 2") + compressed = + MetricsCompression.compressSample previous next + in + TestCase $ + assertEqual + "don't remove changed" + (Just $ StringValue "value 2") + (HashMap.lookup "key" compressed) + + +shouldRemoveUnchangedMetrics :: Test +shouldRemoveUnchangedMetrics = + let + previous = + HashMap.insert "key 2" (StringValue "value 2") $ + HashMap.singleton "key 1" (StringValue "value 1") + next = + HashMap.insert "key 2" (StringValue "value 2 changed") $ + HashMap.singleton "key 1" (StringValue "value 1") + compressed = + MetricsCompression.compressSample previous next + in + TestCase $ + assertEqual + "remove unchanged" + Nothing + (HashMap.lookup "key 1" compressed) + + +shouldLeaveChangedUntouched :: Test +shouldLeaveChangedUntouched = + let + previous = + HashMap.insert "key 2" (StringValue "value 2") $ + HashMap.singleton "key 1" (StringValue "value 1") + next = + HashMap.insert "key 2" (StringValue "value 2 changed") $ + HashMap.singleton "key 1" (StringValue "value 1") + compressed = + MetricsCompression.compressSample previous next + in + TestCase $ + assertEqual + "leave changed" + (Just $ StringValue "value 2 changed") + (HashMap.lookup "key 2" compressed) + diff --git a/test/unit/Instana/SDK/Internal/Metrics/DeltasTest.hs b/test/unit/Instana/SDK/Internal/Metrics/DeltasTest.hs new file mode 100644 --- /dev/null +++ b/test/unit/Instana/SDK/Internal/Metrics/DeltasTest.hs @@ -0,0 +1,182 @@ +{-# LANGUAGE OverloadedStrings #-} +module Instana.SDK.Internal.Metrics.DeltasTest (allTests) where + + +import qualified Data.HashMap.Strict as HashMap +import Data.Maybe (isJust) +import Data.Text (Text) +import Test.HUnit + +import qualified Instana.SDK.Internal.Metrics.Deltas as Deltas +import Instana.SDK.Internal.Metrics.Sample (InstanaMetricValue (..), + InstanaSample, + TimedSample) +import qualified Instana.SDK.Internal.Metrics.Sample as Sample +import Instana.SDK.Internal.Util ((|>)) + + +allTests :: Test +allTests = + TestList + [ TestLabel "shouldComputeDelta" shouldComputeDelta + , TestLabel + "shouldLeaveOriginalValuesUntouched" + shouldLeaveOriginalValuesUntouched + , TestLabel "shouldComputeCorrectDelta" shouldComputeCorrectDelta + , TestLabel "shouldComputeAllDeltas" shouldComputeAllDeltas + , TestLabel + "shouldComputeDeltasWhenPreviousValueIsMissing" + shouldComputeDeltasWhenPreviousValueIsMissing + ] + + +shouldComputeDelta :: Test +shouldComputeDelta = + let + previous = justOneValue 500 10000 + current = justOneValue 600 12000 + withDeltas = Deltas.enrichWithDeltas previous current |> Sample.sample + delta = HashMap.lookup "rts.gc.num_gcs_delta" withDeltas + in + TestCase $ assertBool "delta is present" $ isJust delta + + +shouldLeaveOriginalValuesUntouched :: Test +shouldLeaveOriginalValuesUntouched = + let + previous = justOneValue 500 10000 + current = justOneValue 600 12000 + withDeltas = Deltas.enrichWithDeltas previous current |> Sample.sample + original = HashMap.lookup "rts.gc.num_gcs" withDeltas + in + TestCase $ assertBool "original value is present" $ isJust original + + +shouldComputeCorrectDelta :: Test +shouldComputeCorrectDelta = + let + previous = justOneValue 500 10000 + current = justOneValue 600 12000 + withDeltas = Deltas.enrichWithDeltas previous current |> Sample.sample + deltaValue = getValue "rts.gc.num_gcs_delta" withDeltas + in + TestCase $ + assertEqual + "delta is correct" + 50.0 + deltaValue + + +shouldComputeAllDeltas :: Test +shouldComputeAllDeltas = + let + previous = completeSample 1100 20000 + current = completeSample 1150 23000 + withDeltas = Deltas.enrichWithDeltas previous current |> Sample.sample + in + TestCase $ assertBool "all deltas are present" $ + (isJust $ HashMap.lookup "rts.gc.num_gcs_delta" withDeltas) && + (isJust $ HashMap.lookup "rts.gc.bytes_allocated_delta" withDeltas) && + (isJust $ HashMap.lookup "rts.gc.num_gcs_delta" withDeltas) && + (isJust $ HashMap.lookup "rts.gc.num_bytes_usage_samples_delta" withDeltas) && + (isJust $ HashMap.lookup "rts.gc.cumulative_bytes_used_delta" withDeltas) && + (isJust $ HashMap.lookup "rts.gc.bytes_copied_delta" withDeltas) && + (isJust $ HashMap.lookup "rts.gc.init_cpu_ms_delta" withDeltas) && + (isJust $ HashMap.lookup "rts.gc.init_wall_ms_delta" withDeltas) && + (isJust $ HashMap.lookup "rts.gc.mutator_cpu_ms_delta" withDeltas) && + (isJust $ HashMap.lookup "rts.gc.mutator_wall_ms_delta" withDeltas) && + (isJust $ HashMap.lookup "rts.gc.gc_cpu_ms_delta" withDeltas) && + (isJust $ HashMap.lookup "rts.gc.gc_wall_ms_delta" withDeltas) && + (isJust $ HashMap.lookup "rts.gc.cpu_ms_delta" withDeltas) && + (isJust $ HashMap.lookup "rts.gc.wall_ms_delta" withDeltas) + + +shouldComputeDeltasWhenPreviousValueIsMissing :: Test +shouldComputeDeltasWhenPreviousValueIsMissing = + let + previous = incompleteSample 1100 20000 + current = completeSample 1150 23000 + withDeltas = Deltas.enrichWithDeltas previous current |> Sample.sample + in + TestCase $ assertBool "all deltas are present" $ + (isJust $ HashMap.lookup "rts.gc.num_gcs_delta" withDeltas) && + (isJust $ HashMap.lookup "rts.gc.bytes_allocated_delta" withDeltas) && + (isJust $ HashMap.lookup "rts.gc.num_gcs_delta" withDeltas) && + (isJust $ HashMap.lookup "rts.gc.num_bytes_usage_samples_delta" withDeltas) && + (isJust $ HashMap.lookup "rts.gc.cumulative_bytes_used_delta" withDeltas) && + (isJust $ HashMap.lookup "rts.gc.bytes_copied_delta" withDeltas) && + (isJust $ HashMap.lookup "rts.gc.init_cpu_ms_delta" withDeltas) && + (isJust $ HashMap.lookup "rts.gc.init_wall_ms_delta" withDeltas) && + (isJust $ HashMap.lookup "rts.gc.mutator_cpu_ms_delta" withDeltas) && + (isJust $ HashMap.lookup "rts.gc.mutator_wall_ms_delta" withDeltas) && + (isJust $ HashMap.lookup "rts.gc.gc_cpu_ms_delta" withDeltas) && + (isJust $ HashMap.lookup "rts.gc.gc_wall_ms_delta" withDeltas) && + (isJust $ HashMap.lookup "rts.gc.cpu_ms_delta" withDeltas) && + (isJust $ HashMap.lookup "rts.gc.wall_ms_delta" withDeltas) + + + + +justOneValue :: Int -> Int -> TimedSample +justOneValue metricValue timestamp = + let + sample = + HashMap.singleton "rts.gc.num_gcs" (IntegralValue metricValue) + in + Sample.mkTimedSample sample timestamp + + +completeSample :: Int -> Int -> TimedSample +completeSample offset timestamp = + let + sample = + HashMap.empty + |> HashMap.insert "rts.gc.bytes_allocated" (value offset 100) + |> HashMap.insert "rts.gc.num_gcs" (value offset 110) + |> HashMap.insert "rts.gc.num_bytes_usage_samples" (value offset 120) + |> HashMap.insert "rts.gc.cumulative_bytes_used" (value offset 130) + |> HashMap.insert "rts.gc.bytes_copied" (value offset 140) + |> HashMap.insert "rts.gc.init_cpu_ms" (value offset 150) + |> HashMap.insert "rts.gc.init_wall_ms" (value offset 160) + |> HashMap.insert "rts.gc.mutator_cpu_ms" (value offset 170) + |> HashMap.insert "rts.gc.mutator_wall_ms" (value offset 180) + |> HashMap.insert "rts.gc.gc_cpu_ms" (value offset 190) + |> HashMap.insert "rts.gc.gc_wall_ms" (value offset 200) + |> HashMap.insert "rts.gc.cpu_ms" (value offset 210) + |> HashMap.insert "rts.gc.wall_ms" (value offset 210) + in + Sample.mkTimedSample sample timestamp + + +incompleteSample :: Int -> Int -> TimedSample +incompleteSample offset timestamp = + let + sample = + HashMap.empty + |> HashMap.insert "rts.gc.bytes_allocated" (value offset 100) + |> HashMap.insert "rts.gc.num_bytes_usage_samples" (value offset 120) + |> HashMap.insert "rts.gc.cumulative_bytes_used" (value offset 130) + |> HashMap.insert "rts.gc.init_cpu_ms" (value offset 150) + |> HashMap.insert "rts.gc.init_wall_ms" (value offset 160) + |> HashMap.insert "rts.gc.mutator_wall_ms" (value offset 180) + |> HashMap.insert "rts.gc.gc_wall_ms" (value offset 200) + |> HashMap.insert "rts.gc.wall_ms" (value offset 210) + in + Sample.mkTimedSample sample timestamp + + +value :: Int -> Int -> InstanaMetricValue +value offset val = + IntegralValue $ offset + val + + +getValue :: Text -> InstanaSample -> Double +getValue key sample = + let + maybeValue = HashMap.lookup key sample + in + case maybeValue of + Just (FractionalValue v) -> v + -- arbitrary value that won't match any expectation + _ -> -1000 + diff --git a/test/unit/Instana/SDK/Internal/SecretsTest.hs b/test/unit/Instana/SDK/Internal/SecretsTest.hs new file mode 100644 --- /dev/null +++ b/test/unit/Instana/SDK/Internal/SecretsTest.hs @@ -0,0 +1,242 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +module Instana.SDK.Internal.SecretsTest (allTests) where + + +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Lazy.Char8 as LBSC8 +import Test.HUnit + +import Instana.SDK.Internal.Secrets (SecretsMatcher) +import qualified Instana.SDK.Internal.Secrets as Secrets +import Instana.SDK.Internal.Util ((|>)) + + +allTests :: Test +allTests = + TestList + [ TestLabel "shouldMatchEquals" shouldMatchEquals + , TestLabel "shouldNotMatchEquals" shouldNotMatchEquals + , TestLabel "shouldMatchEqualsIgnoreCase" shouldMatchEqualsIgnoreCase + , TestLabel "shouldNotMatchEqualsIgnoreCase" shouldNotMatchEqualsIgnoreCase + , TestLabel "shouldMatchContains" shouldMatchContains + , TestLabel "shouldNotMatchContains" shouldNotMatchContains + , TestLabel "shouldMatchContainsIgnoreCase" shouldMatchContainsIgnoreCase + , TestLabel + "shouldNotMatchContainsIgnoreCase" + shouldNotMatchContainsIgnoreCase + , TestLabel "shouldMatchRegex" shouldMatchRegex + , TestLabel "shouldMatchRegex2" shouldMatchRegex2 + , TestLabel "shouldNotMatchRegex" shouldNotMatchRegex + , TestLabel + "shouldNotMatchRegexCaseInsensitive" + shouldNotMatchRegexCaseInsensitive + , TestLabel + "shouldNotMatchWhenRegexMatchesASubstring" + shouldNotMatchWhenRegexMatchesASubstring + , TestLabel + "shouldHandleStartAndEndOfLineSpecialChars" + shouldHandleStartAndEndOfLineSpecialChars + , TestLabel + "shouldHandleStartAndEndOfLineSpecialChars2" + shouldHandleStartAndEndOfLineSpecialChars2 + , TestLabel + "shouldHandleStartAndEndOfLineSpecialChars3" + shouldHandleStartAndEndOfLineSpecialChars3 + ] + + +shouldMatchEquals :: Test +shouldMatchEquals = + let + config = createConfig "equals" + in + TestCase $ + assertBool "equals should match" $ Secrets.isSecret config "PASS" + + +shouldNotMatchEquals :: Test +shouldNotMatchEquals = + let + config = createConfig "equals" + in + TestCase $ + assertBool "equals should not match" $ + not $ Secrets.isSecret config "pass" + + +shouldMatchEqualsIgnoreCase :: Test +shouldMatchEqualsIgnoreCase = + let + config = createConfig "equals-ignore-case" + in + TestCase $ + assertBool "equals ignore case should match" $ + Secrets.isSecret config "pAsS" + + +shouldNotMatchEqualsIgnoreCase :: Test +shouldNotMatchEqualsIgnoreCase = + let + config = createConfig "equals-ignore-case" + in + TestCase $ + assertBool "equals ignore case should not match" $ + not $ Secrets.isSecret config "XpAssX" + + +shouldMatchContains :: Test +shouldMatchContains = + let + config = createConfig "contains" + in + TestCase $ + assertBool "contains should match" $ Secrets.isSecret config "ABCPASSDEF" + + +shouldNotMatchContains :: Test +shouldNotMatchContains = + let + config = createConfig "contains" + in + TestCase $ + assertBool "contains should not match" $ + not $ Secrets.isSecret config "abcpassdef" + + +shouldMatchContainsIgnoreCase :: Test +shouldMatchContainsIgnoreCase = + let + config = createConfig "contains-ignore-case" + in + TestCase $ + assertBool "contains ignore case should match" $ + Secrets.isSecret config "abcpAsSdef" + + +shouldNotMatchContainsIgnoreCase :: Test +shouldNotMatchContainsIgnoreCase = + let + config = createConfig "contains-ignore-case" + in + TestCase $ + assertBool "contains ignore case should not match" $ + not $ Secrets.isSecret config "abPp4SSdef" + + +shouldMatchRegex :: Test +shouldMatchRegex = + TestCase $ + assertBool "regex should match" $ + Secrets.isSecret regexConfig "abcWHATEVERxyz" + + +shouldMatchRegex2 :: Test +shouldMatchRegex2 = + TestCase $ + assertBool "regex should match 2" $ + Secrets.isSecret regexConfig "123" + + +shouldNotMatchRegex :: Test +shouldNotMatchRegex = + TestCase $ + assertBool "regex should not match" $ + not $ Secrets.isSecret regexConfig "efgXuvw" + + +shouldNotMatchRegexCaseInsensitive :: Test +shouldNotMatchRegexCaseInsensitive = + TestCase $ + assertBool "regex should not match case insensitive" $ + not $ Secrets.isSecret regexConfig "ABCWHATEVERXYZ" + + +shouldNotMatchWhenRegexMatchesASubstring :: Test +shouldNotMatchWhenRegexMatchesASubstring = + TestCase $ + assertBool "regex should not match substring" $ + not $ Secrets.isSecret regexConfig "ZZZabcXXXxyzZZZ" + + +shouldHandleStartAndEndOfLineSpecialChars :: Test +shouldHandleStartAndEndOfLineSpecialChars = + TestCase $ + assertBool "regex should handle ^ and $" $ + Secrets.isSecret (regexConfigFor "^regex$") "regex" + + +shouldHandleStartAndEndOfLineSpecialChars2 :: Test +shouldHandleStartAndEndOfLineSpecialChars2 = + TestCase $ + assertBool "regex should handle ^ and $" $ + not $ Secrets.isSecret (regexConfigFor "^regex$") "xregex" + + +shouldHandleStartAndEndOfLineSpecialChars3 :: Test +shouldHandleStartAndEndOfLineSpecialChars3 = + TestCase $ + assertBool "regex should handle ^ and $" $ + not $ Secrets.isSecret (regexConfigFor "^regex$") "regexx" + +-- describe('none', function() { +-- var matcher; +-- +-- beforeEach(function() { +-- matcher = secrets.matchers.none(['secret-key', 'anotherKey', 'whatever']); +-- }); +-- +-- it('should not match anything', function() { +-- expect(matcher('secret-key')).to.be.false; +-- expect(matcher('key')).to.be.false; +-- expect(matcher('pass')).to.be.false; +-- }); +-- }); +-- }); + + +createConfig :: String -> SecretsMatcher +createConfig matcherMode = + -- The JSON decoding applies preprocessing on the secrets list (for example, + -- it lower cases all strings when the matcher is an ignore-case matcher), so + -- it is part of the actual matching logic and needs to be included in the + -- tests, so we create a SecretsMatcher by parsing some JSON. + let + maybeConfig :: Maybe SecretsMatcher + maybeConfig = + ("{ \"matcher\": \"" ++ matcherMode ++ "\", " ++ + "\"list\": [\"KEY\", \"PASS\", \"SECRET\"] }") + |> LBSC8.pack + |> Aeson.decode + Just config = maybeConfig + in + config + + +regexConfig :: SecretsMatcher +regexConfig = + let + maybeConfig :: Maybe SecretsMatcher + maybeConfig = + ("{ \"matcher\": \"regex\", " ++ + "\"list\": [\"abc.*xyz\", \"[0-9]{1,3}\"] }") + |> LBSC8.pack + |> Aeson.decode + Just config = maybeConfig + in + config + + +regexConfigFor :: String -> SecretsMatcher +regexConfigFor singleRegex = + let + maybeConfig :: Maybe SecretsMatcher + maybeConfig = + ("{ \"matcher\": \"regex\", " ++ + "\"list\": [\"" ++ singleRegex ++ "\"] }") + |> LBSC8.pack + |> Aeson.decode + Just config = maybeConfig + in + config + diff --git a/test/unit/Instana/SDK/Internal/SpanStackTest.hs b/test/unit/Instana/SDK/Internal/SpanStackTest.hs new file mode 100644 --- /dev/null +++ b/test/unit/Instana/SDK/Internal/SpanStackTest.hs @@ -0,0 +1,326 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Instana.SDK.Internal.SpanStackTest (allTests) where + +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 (..)) + + +allTests :: Test +allTests = + TestList + [ TestLabel "shouldCreateEmpty" shouldCreateEmpty + , TestLabel "popShouldReturnNothingOnEmpty" popShouldReturnNothingOnEmpty + , TestLabel "popWhenMatchesShouldReturnNothingOnEmpty" + popWhenMatchesShouldReturnNothingOnEmpty + , TestLabel "peekShouldReturnNothingOnEmpty" peekShouldReturnNothingOnEmpty + , TestLabel "popEmptyShouldLeaveEmpty" popEmptyShouldLeaveEmpty + , TestLabel "popWhenMatchesEmptyShouldLeaveEmpty" + popWhenMatchesEmptyShouldLeaveEmpty + , TestLabel "shouldPushEntry" shouldPushEntry + , TestLabel "shouldNotPushExitOnEmpty" shouldNotPushExitOnEmpty + , TestLabel "popShouldReturnEntry" popShouldReturnEntry + , TestLabel "popWhenMatchesShouldReturnEntry" + popWhenMatchesShouldReturnEntry + , TestLabel "popWhenNotMatchesEntryShouldReturnNothing" + popWhenNotMatchesEntryShouldReturnNothing + , TestLabel "peekShouldReturnEntry" peekShouldReturnEntry + , TestLabel "popEntryShouldLeaveEmpty" popEntryShouldLeaveEmpty + , TestLabel "popEntryWhenMatchesShouldLeaveEmpty" + popEntryWhenMatchesShouldLeaveEmpty + , TestLabel "popEntryWhenNotMatchesEntryShouldLeaveStackUnchanged" + popEntryWhenNotMatchesEntryShouldLeaveStackUnchanged + , TestLabel "shouldPushExit" shouldPushExit + , TestLabel "shouldNotPushEntryOnEntry" shouldNotPushEntryOnEntry + , TestLabel "popShouldReturnExit" popShouldReturnExit + , TestLabel "popWhenMatchesShouldReturnExit" popWhenMatchesShouldReturnExit + , TestLabel "popWhenNotMatchesExitShouldReturnNothing" + popWhenNotMatchesExitShouldReturnNothing + , TestLabel "peekShouldReturnExit" peekShouldReturnExit + , TestLabel "popExitShouldLeaveNotEmpty" popExitShouldLeaveNotEmpty + , TestLabel "popExitWhenMatcheShouldLeaveNotEmpty" + popExitWhenMatcheShouldLeaveNotEmpty + , TestLabel "popExitWhenNotMatcheExitShouldLeaveNotEmpty" + popExitWhenNotMatcheExitShouldLeaveNotEmpty + , TestLabel "popPopShouldReturnEntry" popPopShouldReturnEntry + , TestLabel "popPeekShouldReturnEntry" popPeekShouldReturnEntry + , TestLabel "popPopShouldLeaveEmpty" popPopShouldLeaveEmpty + ] + + +shouldCreateEmpty :: Test +shouldCreateEmpty = + TestCase $ + assertBool "empty" $ SpanStack.isEmpty empty + + +popShouldReturnNothingOnEmpty :: Test +popShouldReturnNothingOnEmpty = + TestCase $ + assertEqual "empty#pop" Nothing (snd $ SpanStack.pop empty) + + +popWhenMatchesShouldReturnNothingOnEmpty :: Test +popWhenMatchesShouldReturnNothingOnEmpty = + TestCase $ + assertEqual "empty#popWhenMatches" Nothing (snd3 $ SpanStack.popWhenMatches EntryKind empty) + + +peekShouldReturnNothingOnEmpty :: Test +peekShouldReturnNothingOnEmpty = + TestCase $ + assertEqual "empty#peek" Nothing (SpanStack.peek empty) + + +popEmptyShouldLeaveEmpty :: Test +popEmptyShouldLeaveEmpty = + TestCase $ + assertBool "empty#pop leaves empty" $ + SpanStack.isEmpty $ (fst $ SpanStack.pop empty) + + +popWhenMatchesEmptyShouldLeaveEmpty :: Test +popWhenMatchesEmptyShouldLeaveEmpty = + TestCase $ + assertBool "empty#popWhenMatches leaves empty" $ + SpanStack.isEmpty $ (fst3 $ SpanStack.popWhenMatches EntryKind empty) + + +shouldPushEntry :: Test +shouldPushEntry = + TestCase $ + assertBool "push entry" $ not $ SpanStack.isEmpty entryOnly + + +shouldNotPushExitOnEmpty :: Test +shouldNotPushExitOnEmpty = + let + stack = SpanStack.push (Exit exitSpan) $ SpanStack.empty + in + TestCase $ + assertBool "push exit on emtpy" $ SpanStack.isEmpty stack + + +popShouldReturnEntry :: Test +popShouldReturnEntry = + TestCase $ + assertEqual "push/pop" + (Just $ Entry entrySpan) + (snd $ SpanStack.pop entryOnly) + + +popWhenMatchesShouldReturnEntry :: Test +popWhenMatchesShouldReturnEntry = + TestCase $ + assertEqual "push/popWhenMatches" + (Just $ Entry entrySpan) + (snd3 $ SpanStack.popWhenMatches EntryKind entryOnly) + + +popWhenNotMatchesEntryShouldReturnNothing :: Test +popWhenNotMatchesEntryShouldReturnNothing = + TestCase $ + assertEqual "push/popWhenNotMatches" + (Nothing) + (snd3 $ SpanStack.popWhenMatches ExitKind entryOnly) + + +peekShouldReturnEntry :: Test +peekShouldReturnEntry = + TestCase $ + assertEqual "push/peek" + (Just $ Entry entrySpan) + (SpanStack.peek entryOnly) + + +popEntryShouldLeaveEmpty :: Test +popEntryShouldLeaveEmpty = + TestCase $ + assertBool "push/pop leaves empty" $ + SpanStack.isEmpty $ (fst $ SpanStack.pop entryOnly) + + +popEntryWhenMatchesShouldLeaveEmpty :: Test +popEntryWhenMatchesShouldLeaveEmpty = + TestCase $ + assertBool "push/popWhenMatches leaves empty" $ + SpanStack.isEmpty $ (fst3 $ SpanStack.popWhenMatches EntryKind entryOnly) + + +popEntryWhenNotMatchesEntryShouldLeaveStackUnchanged :: Test +popEntryWhenNotMatchesEntryShouldLeaveStackUnchanged = + let + newStack = fst3 $ SpanStack.popWhenMatches ExitKind entryOnly + top = SpanStack.peek newStack + in + TestCase $ + assertEqual "push/popWhenNotMatches leaves stack unchanged" + (Just $ Entry entrySpan) + top + + +shouldPushExit :: Test +shouldPushExit = + TestCase $ + assertBool "push exit" $ not $ SpanStack.isEmpty entryAndExit + + +shouldNotPushEntryOnEntry :: Test +shouldNotPushEntryOnEntry = + let + stack = SpanStack.push (Entry entrySpan) $ entryOnly + top = SpanStack.peek stack + in + TestCase $ + assertEqual "push entry on entry" + (Just $ Entry entrySpan) + top + + +popShouldReturnExit :: Test +popShouldReturnExit = + TestCase $ + assertEqual "push/push/pop" + (Just $ Exit exitSpan) + (snd $ SpanStack.pop entryAndExit) + + +popWhenMatchesShouldReturnExit :: Test +popWhenMatchesShouldReturnExit = + TestCase $ + assertEqual "push/push/popWhenMatches" + (Just $ Exit exitSpan) + (snd3 $ SpanStack.popWhenMatches ExitKind entryAndExit) + + +popWhenNotMatchesExitShouldReturnNothing :: Test +popWhenNotMatchesExitShouldReturnNothing = + let + in + TestCase $ + assertEqual "push/push/popWhenNotMatches" + Nothing + (snd3 $ SpanStack.popWhenMatches EntryKind entryAndExit) + + +peekShouldReturnExit :: Test +peekShouldReturnExit = + TestCase $ + assertEqual "push/push/peek" + (Just $ Exit exitSpan) + (SpanStack.peek entryAndExit) + + +popExitShouldLeaveNotEmpty :: Test +popExitShouldLeaveNotEmpty = + TestCase $ + assertBool "push/push/pop leaves not empty" $ + not $ SpanStack.isEmpty $ (fst $ SpanStack.pop entryAndExit) + + +popExitWhenMatcheShouldLeaveNotEmpty :: Test +popExitWhenMatcheShouldLeaveNotEmpty = + TestCase $ + assertBool "push/push/popWhenMatches leaves not empty" $ + not $ SpanStack.isEmpty $ + (fst3 $ SpanStack.popWhenMatches ExitKind entryAndExit) + + +popExitWhenNotMatcheExitShouldLeaveNotEmpty :: Test +popExitWhenNotMatcheExitShouldLeaveNotEmpty = + let + newStack = fst3 $ SpanStack.popWhenMatches EntryKind entryAndExit + top = SpanStack.peek newStack + in + TestCase $ + assertEqual "push/push/popWhenNotMatches leaves stack unchanged" + (Just $ Exit exitSpan) + top + + +popPopShouldReturnEntry :: Test +popPopShouldReturnEntry = + TestCase $ + assertEqual "push/push/pop/pop" + (Just $ Entry entrySpan) + (snd $ SpanStack.pop $ fst $ SpanStack.pop entryAndExit) + + +popPeekShouldReturnEntry :: Test +popPeekShouldReturnEntry = + TestCase $ + assertEqual "push/push/pop/peek" + (Just $ Entry entrySpan) + (SpanStack.peek $ fst $ SpanStack.pop entryAndExit) + + +popPopShouldLeaveEmpty :: Test +popPopShouldLeaveEmpty = + TestCase $ + assertBool "push/push/pop/pop leaves empty" $ + SpanStack.isEmpty $ + fst $ SpanStack.pop $ + fst $ SpanStack.pop entryAndExit + + +empty :: SpanStack +empty = + SpanStack.empty + + +entryOnly :: SpanStack +entryOnly = + SpanStack.push (Entry entrySpan) $ empty + + +entryAndExit :: SpanStack +entryAndExit = + SpanStack.push (Exit exitSpan) $ entryOnly + + +entrySpan :: EntrySpan +entrySpan = + RootEntrySpan $ + RootEntry + { RootEntry.spanAndTraceId = Id.fromString "traceId" + , RootEntry.spanName = "test.entry" + , RootEntry.timestamp = 1514761200000 + , RootEntry.spanData = emptyValue + , RootEntry.errorCount = 0 + } + + +exitSpan :: ExitSpan +exitSpan = + ExitSpan + { ExitSpan.parentSpan = entrySpan + , ExitSpan.spanId = Id.fromString "spanId" + , ExitSpan.spanName = "test.exit" + , ExitSpan.timestamp = 1514761201000 + , ExitSpan.spanData = emptyValue + , ExitSpan.errorCount = 0 + } + + +emptyValue :: Value +emptyValue = Aeson.object [] + + +fst3 :: (a, b, c) -> a +fst3 (a, _, _) = a + + +snd3 :: (a, b, c) -> b +snd3 (_, b, _) = b + diff --git a/test/unit/Instana/SDK/Internal/SpanTest.hs b/test/unit/Instana/SDK/Internal/SpanTest.hs new file mode 100644 --- /dev/null +++ b/test/unit/Instana/SDK/Internal/SpanTest.hs @@ -0,0 +1,201 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Instana.SDK.Internal.SpanTest (allTests) where + + +import Data.Aeson (Value, (.=)) +import qualified Data.Aeson as Aeson +import Test.HUnit + +import qualified Instana.SDK.Internal.Id as Id +import Instana.SDK.Span.EntrySpan (EntrySpan (RootEntrySpan)) +import Instana.SDK.Span.RootEntry (RootEntry (RootEntry)) +import qualified Instana.SDK.Span.RootEntry as RootEntry +import Instana.SDK.Span.Span (Span (..)) +import qualified Instana.SDK.Span.Span as Span + + +allTests :: Test +allTests = + TestList + [ TestLabel "shouldAddStringNotNested" shouldAddStringNotNested + , TestLabel "shouldAddStringNested" shouldAddStringNested + , TestLabel "shouldAddStringDeeplyNested" shouldAddStringDeeplyNested + , TestLabel "shouldAddIntDeeplyNested" shouldAddIntDeeplyNested + , TestLabel "shouldAddDoubleDeeplyNested" shouldAddDoubleDeeplyNested + , TestLabel "shouldAddBooleanDeeplyNested" shouldAddBooleanDeeplyNested + , TestLabel "shouldAddMultiple" shouldAddMultiple + ] + + +shouldAddStringNotNested :: Test +shouldAddStringNotNested = + let + span_ = Span.addDataAt "path" ("value" :: String) $ entrySpan + spanData = Span.spanData span_ + in + TestCase $ + assertEqual "add non nested" + (Aeson.object [ + "path" .= ("value" :: String) + ]) + spanData + + +shouldAddStringNested :: Test +shouldAddStringNested = + let + span_ = + Span.addDataAt + "nested.path" + ("value" :: String) $ + entrySpan + spanData = Span.spanData span_ + in + TestCase $ + assertEqual "add nested" + (Aeson.object [ + "nested" .= (Aeson.object [ + "path" .= ("value" :: String) + ]) + ]) + spanData + + +shouldAddStringDeeplyNested :: Test +shouldAddStringDeeplyNested = + let + span_ = + Span.addDataAt + "really.deeply.nested.path" + ("deeplyNestedValue" :: String) $ + entrySpan + spanData = Span.spanData span_ + in + TestCase $ + assertEqual "add deeply nested" + (Aeson.object [ + "really" .= (Aeson.object [ + "deeply" .= (Aeson.object [ + "nested" .= (Aeson.object [ + "path" .= ("deeplyNestedValue" :: String) + ]) + ]) + ]) + ]) + spanData + + +shouldAddIntDeeplyNested :: Test +shouldAddIntDeeplyNested = + let + span_ = + Span.addDataAt + "really.deeply.nested.path" + (42 :: Int) $ + entrySpan + spanData = Span.spanData span_ + in + TestCase $ + assertEqual "add deeply nested" + (Aeson.object [ + "really" .= (Aeson.object [ + "deeply" .= (Aeson.object [ + "nested" .= (Aeson.object [ + "path" .= (42 :: Int) + ]) + ]) + ]) + ]) + spanData + + +shouldAddDoubleDeeplyNested :: Test +shouldAddDoubleDeeplyNested = + let + span_ = + Span.addDataAt + "really.deeply.nested.path" + (28.08 :: Double) $ + entrySpan + spanData = Span.spanData span_ + in + TestCase $ + assertEqual "add deeply nested" + (Aeson.object [ + "really" .= (Aeson.object [ + "deeply" .= (Aeson.object [ + "nested" .= (Aeson.object [ + "path" .= (28.08 :: Double) + ]) + ]) + ]) + ]) + spanData + + +shouldAddBooleanDeeplyNested :: Test +shouldAddBooleanDeeplyNested = + let + span_ = Span.addDataAt "really.deeply.nested.path" True $ entrySpan + spanData = Span.spanData span_ + in + TestCase $ + assertEqual "add deeply nested" + (Aeson.object [ + "really" .= (Aeson.object [ + "deeply" .= (Aeson.object [ + "nested" .= (Aeson.object [ + "path" .= True + ]) + ]) + ]) + ]) + spanData + + +shouldAddMultiple :: Test +shouldAddMultiple = + let + span_ = + Span.addDataAt "nested.key3" (12.07 :: Double) $ + Span.addDataAt "nested.key2" (2 :: Int) $ + Span.addDataAt "nested.key1" ("value.n.1" :: String) $ + Span.addDataAt "key3" (16.04 :: Double) $ + Span.addDataAt "key2" (13 :: Int) $ + Span.addDataAt "key1" ("value1" :: String) $ + entrySpan + spanData = Span.spanData span_ + in + TestCase $ + assertEqual "add deeply nested" + (Aeson.object + [ "key1" .= ("value1" :: String) + , "key2" .= (13 :: Int) + , "key3" .= (16.04 :: Double) + , "nested" .= (Aeson.object + [ "key1" .= ("value.n.1" :: String) + , "key2" .= (2 :: Int) + , "key3" .= (12.07 :: Double) + ]) + ] + ) + spanData + + +entrySpan :: Span +entrySpan = + Entry $ + RootEntrySpan $ + RootEntry + { RootEntry.spanAndTraceId = Id.fromString "traceId" + , RootEntry.spanName = "test.entry" + , RootEntry.timestamp = 1514761200000 + , RootEntry.spanData = initialData + , RootEntry.errorCount = 0 + } + + +initialData :: Value +initialData = Aeson.object [] + diff --git a/test/unit/Main.hs b/test/unit/Main.hs new file mode 100644 --- /dev/null +++ b/test/unit/Main.hs @@ -0,0 +1,35 @@ +module Main where + + +import qualified Instana.SDK.Internal.AgentConnection.SchedFileTest as SchedFileTest +import qualified Instana.SDK.Internal.ConfigTest as ConfigTest +import qualified Instana.SDK.Internal.IdTest as IdTest +import qualified Instana.SDK.Internal.LoggingTest as LoggingTest +import qualified Instana.SDK.Internal.Metrics.CompressionTest as MetricsCompressionTest +import qualified Instana.SDK.Internal.Metrics.DeltasTest as MetricsDeltasTest +import qualified Instana.SDK.Internal.SecretsTest as SecretsTest +import qualified Instana.SDK.Internal.SpanStackTest as SpanStackTest +import qualified Instana.SDK.Internal.SpanTest as SpanTest + +import Test.HUnit + + +main :: IO Counts +main = do + runTestTT allTests + + +allTests :: Test +allTests = + TestList + [ ConfigTest.allTests + , IdTest.allTests + , LoggingTest.allTests + , MetricsCompressionTest.allTests + , MetricsDeltasTest.allTests + , SecretsTest.allTests + , SpanTest.allTests + , SpanStackTest.allTests + , SchedFileTest.allTests + ] +