instana-haskell-trace-sdk 0.6.0.0 → 0.6.1.0
raw patch · 11 files changed
+266/−31 lines, 11 files
Files
- CHANGELOG.md +3/−0
- CONTRIBUTING.md +2/−1
- README.md +1/−1
- instana-haskell-trace-sdk.cabal +1/−1
- src/Instana/SDK/Internal/SpanStack.hs +19/−0
- src/Instana/SDK/SDK.hs +54/−7
- test/apps/wai-with-middleware/Main.hs +42/−7
- test/integration/Instana/SDK/IntegrationTest/Metrics.hs +1/−1
- test/integration/Instana/SDK/IntegrationTest/TestSuites.hs +1/−0
- test/integration/Instana/SDK/IntegrationTest/WaiMiddleware.hs +39/−12
- test/unit/Instana/SDK/Internal/SpanStackTest.hs +103/−1
CHANGELOG.md view
@@ -1,5 +1,8 @@ # Changelog for instana-haskell-trace-sdk +## 0.6.1.0+- Fix: Capture HTTP status code in `postProcessHttpRespons` even if an the currently active span is an exit.+ ## 0.6.0.0 - Fix: Pass span ID of exit span downstream with X-INSTANA-S instead of the entry span's span ID. - Fix: Capture HTTP status code in `withHttpEntry` (formely `withCorrelatedHttpEntry`).
CONTRIBUTING.md view
@@ -68,10 +68,11 @@ * Update `README.md` with API changes. * Update `CHANGELOG.md` (update/add entry) * Commit and push this change with a commit comment like `chore: version a.b.c.d`+* Wait for the CI build for branch main. * Build the package with stack and upload it to Hackage: * `stack haddock && stack sdist && stack upload .` Actually, the Hackage server should build the haddock docs after the package has been uploaded and add it to the package version. You can check if this has worked - if the individual modules on <http://hackage.haskell.org/package/instana-haskell-trace-sdk> are links to the documentation, it worked. Legend has it that this takes a few minutes - you could theoretically wait to see if the docs show up. Most of the times this does not actually work for reasons unknown. In these cases you can build the docs manually in the format Hackage expects and upload them for an already published package version by running ```-bin/build-and-upload-docs.sh+bin/build-and-upload-docs.sh $YOUR_HACKAGE_USER ```
README.md view
@@ -20,7 +20,7 @@ ``` extra-deps:-- instana-haskell-trace-sdk-0.6.0.0+- instana-haskell-trace-sdk-0.6.1.0 ``` Depending on the stack resolver you use, you might also need to add `aeson-extra` to your extra-deps:
instana-haskell-trace-sdk.cabal view
@@ -1,5 +1,5 @@ name: instana-haskell-trace-sdk-version: 0.6.0.0+version: 0.6.1.0 synopsis: SDK for adding custom Instana tracing support to Haskell applications. description: Please also see the README on Github at <https://github.com/instana/haskell-trace-sdk#readme> homepage: https://www.instana.com/
src/Instana/SDK/Internal/SpanStack.hs view
@@ -9,6 +9,7 @@ , entry , isEmpty , isSuppressed+ , mapEntry , mapTop , peek , pop@@ -219,4 +220,22 @@ newTop = fn oldTop in push newTop remainder+++{-|Modifies the entry span in place by applying the given function to it. This+is a no op if the span stack is empty. This function will never modify the exit+span.+-}+mapEntry :: (Span -> Span) -> SpanStack -> SpanStack+mapEntry _ None =+ None+mapEntry _ Suppressed =+ Suppressed+mapEntry fn (EntryOnly entrySpan) =+ mapTop fn (EntryOnly entrySpan)+mapEntry fn (EntryAndExit oldEntrySpan oldExitSpan) =+ let+ (Entry newEntrySpan) = fn (Entry oldEntrySpan)+ in+ EntryAndExit newEntrySpan oldExitSpan
src/Instana/SDK/SDK.hs view
@@ -86,7 +86,8 @@ 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 Instana.SDK.Internal.Context (ConnectionState (..),+ InternalContext (InternalContext)) import qualified Instana.SDK.Internal.Context as InternalContext import Instana.SDK.Internal.Id (Id) import qualified Instana.SDK.Internal.Id as Id@@ -282,10 +283,7 @@ -> Wai.Request -> m Wai.Response -> m Wai.Response-withHttpEntry- context- request- io = do+withHttpEntry context request io = do response <- withHttpEntry_ context request $ do io >>= postProcessHttpResponse context return response@@ -563,6 +561,11 @@ -- Client code should rarely have the need to call this directly. Instead, -- capture incoming HTTP requests with 'withHttpEntry', which does -- both of these things automatically.+--+-- Clients should make sure to call this in the context povided above, that is,+-- within 'withHttpEntry_ or between 'startHttpEntry' and 'completeHttpEntry'+-- but outside of blocks that create create an exit span, that is, outside of+-- 'withExit', 'withHttpExit' and not between 'startExit' and 'completeExit'. postProcessHttpResponse :: MonadIO m => InstanaContext@@ -606,7 +609,7 @@ let (HTTPTypes.Status statusCode statusMessage) = Wai.responseStatus response- addRegisteredDataAt context "http.status" statusCode+ addRegisteredDataToEntryAt context "http.status" statusCode when (statusCode >= 500 ) (addRegisteredDataAt context "http.message" $@@ -946,6 +949,21 @@ (\span_ -> Span.addRegisteredDataAt path value span_) +-- |Adds additional meta data to the currently active entry span, even if the+-- currently active span is an exit child of that entry span.+--+-- Note that this should only be used for registered spans, not for SDK spans.+addRegisteredDataToEntryAt ::+ (MonadIO m, Aeson.ToJSON a) =>+ InstanaContext+ -> Text+ -> a+ -> m ()+addRegisteredDataToEntryAt context path value =+ liftIO $ modifyCurrentEntrySpan context+ (\span_ -> Span.addRegisteredDataAt path value span_)++ -- |Adds additional data to the currently active registered span. Call this -- between startEntry/startRootEntry/startExit and completeEntry/completeExit or -- inside the IO action given to with withEntry/withExit/withRootEntry. Can be@@ -1222,10 +1240,39 @@ ) --- |Applies the given function to the given span.+-- |Applies the given function to the top item on the given span stack. mapCurrentSpan :: (Span -> Span) -> Maybe SpanStack -> SpanStack mapCurrentSpan fn stack = Maybe.fromMaybe SpanStack.empty ((SpanStack.mapTop fn) <$> stack)+++-- |Applies the given function to the currently active entry span, even if the+-- currently active span is an exit child of that entry span. The entry span+-- will be replaced with the result of the given function.+modifyCurrentEntrySpan ::+ InstanaContext+ -> (Span -> Span)+ -> IO ()+modifyCurrentEntrySpan context fn = do+ threadId <- Concurrent.myThreadId+ STM.atomically $+ STM.modifyTVar' (InternalContext.currentSpans context)+ (\currentSpansPerThread ->+ let+ stack = Map.lookup threadId currentSpansPerThread+ modifiedStack = mapCurrentEntrySpan fn stack+ in+ Map.insert threadId modifiedStack currentSpansPerThread+ )+++-- |Applies the given function to the entry span (if present) on the given span+-- stack, even if there is already an exit span on top of it.+mapCurrentEntrySpan :: (Span -> Span) -> Maybe SpanStack -> SpanStack+mapCurrentEntrySpan fn stack =+ Maybe.fromMaybe+ SpanStack.empty+ ((SpanStack.mapEntry fn) <$> stack)
test/apps/wai-with-middleware/Main.hs view
@@ -20,10 +20,9 @@ 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 System.Log.Logger (Priority (..), infoM,+ rootLoggerName, setHandlers,+ setLevel, updateGlobalLogger) import qualified System.Posix.Process as Posix import System.Posix.Types (CPid) @@ -44,6 +43,8 @@ ping respond pid ("GET", ["api"]) -> apiUnderTest instana httpManager request respond+ ("GET", ["wrong-nesting"]) ->+ apiUnderTestWithWrongNesting instana httpManager request respond ("POST", ["shutdown"]) -> shutDown respond _ ->@@ -82,15 +83,49 @@ instana downstreamRequest (\req -> do- dowstreamRequest' <- HTTP.httpLbs req httpManager- threadDelay $ 1000 -- make sure there is a duration > 0- return dowstreamRequest'+ -- make sure there is a duration > 0+ threadDelay $ 1000+ -- execute downstream request+ HTTP.httpLbs req httpManager ) respond $ Wai.responseLBS HTTPTypes.status200 [("Content-Type", "application/json; charset=UTF-8")] (HTTP.responseBody downstreamResponse)+++-- | In this handler, sending the response to the incoming HTTP request is+-- nested within the withHttpExit call. Technically, it is a wrong usage pattern+-- but we have some mechanisms in place to cope with it.+apiUnderTestWithWrongNesting ::+ InstanaContext+ -> HTTP.Manager+ -> Wai.Request+ -> (Wai.Response -> IO Wai.ResponseReceived)+ -> IO Wai.ResponseReceived+apiUnderTestWithWrongNesting instana httpManager _ respond = do+ downstreamRequest <-+ HTTP.parseUrlThrow $+ "http://127.0.0.1:1208/echo?some=query¶meters=2&pass=secret"+ InstanaSDK.withHttpExit+ instana+ downstreamRequest+ (\req -> do+ -- make sure there is a duration > 0+ threadDelay $ 1000+ -- execute downstream request+ downstreamResponse <- HTTP.httpLbs req httpManager+ -- Send response within withHttpExit block. This is wrong because it will+ -- finish the HTTP entry while the HTTP exit is still active. Wai's+ -- respond callback should be called outside of withHttpExit. But the SDK+ -- can cope with it to some degree.+ respond $+ Wai.responseLBS+ HTTPTypes.status200+ [("Content-Type", "application/json; charset=UTF-8")]+ (HTTP.responseBody downstreamResponse)+ ) shutDown ::
test/integration/Instana/SDK/IntegrationTest/Metrics.hs view
@@ -51,7 +51,7 @@ (EntityDataRequest.arguments entityData) , assertLabelIs "sensorVersion"- "0.6.0.0"+ "0.6.1.0" (EntityDataRequest.sensorVersion entityData) , assertCounterSatisfies "startTime"
test/integration/Instana/SDK/IntegrationTest/TestSuites.hs view
@@ -151,6 +151,7 @@ , WaiMiddleware.shouldCreateNonRootEntry pid , WaiMiddleware.shouldAddWebsiteMonitoringCorrelation pid , WaiMiddleware.shouldSuppress+ , WaiMiddleware.shouldCopeWithWrongNestingOfIoActions pid ]) , Suite.options = Suite.defaultOptions { Suite.appsUnderTest =
test/integration/Instana/SDK/IntegrationTest/WaiMiddleware.hs view
@@ -4,6 +4,7 @@ , shouldCreateNonRootEntry , shouldAddWebsiteMonitoringCorrelation , shouldSuppress+ , shouldCopeWithWrongNestingOfIoActions ) where @@ -17,9 +18,9 @@ import Data.Maybe (isNothing, listToMaybe) 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,+import Instana.SDK.IntegrationTest.HUnitExtra (applyLabel, assertAllIO, failIO)+import qualified Instana.SDK.IntegrationTest.HttpHelper as HttpHelper import qualified Instana.SDK.IntegrationTest.Suite as Suite import qualified Instana.SDK.IntegrationTest.TestHelper as TestHelper import qualified Network.HTTP.Client as HTTP@@ -31,7 +32,11 @@ shouldCreateRootEntry :: String -> IO Test shouldCreateRootEntry pid = applyLabel "shouldCreateRootEntry" $- runMiddlewareTest pid [] (applyConcat [rootEntryAsserts, asserts])+ runMiddlewareTest+ pid+ "api"+ []+ (applyConcat [rootEntryAsserts, asserts "api"]) shouldCreateNonRootEntry :: String -> IO Test@@ -39,10 +44,11 @@ applyLabel "shouldCreateNonRootEntry" $ do runMiddlewareTest pid+ "api" [ ("X-INSTANA-T", "test-trace-id") , ("X-INSTANA-S", "test-span-id") ]- (applyConcat [nonRootEntryAsserts, asserts])+ (applyConcat [nonRootEntryAsserts, asserts "api"]) shouldAddWebsiteMonitoringCorrelation :: String -> IO Test@@ -50,8 +56,9 @@ applyLabel "shouldAddWebsiteMonitoringCorrelation" $ runMiddlewareTest pid+ "api" [("X-INSTANA-L", " 1 , correlationType = web ; correlationId = 1234567890abcdef ")]- (applyConcat [rootEntryAsserts, asserts, correlationAsserts])+ (applyConcat [rootEntryAsserts, asserts "api", correlationAsserts]) shouldSuppress :: IO Test@@ -60,11 +67,25 @@ runSuppressedTest "api" -runMiddlewareTest :: String -> [Header] -> (Span -> [Assertion]) -> IO Test-runMiddlewareTest pid headers extraAsserts =- runTest pid "api?some=query¶meters=1" headers extraAsserts+shouldCopeWithWrongNestingOfIoActions :: String -> IO Test+shouldCopeWithWrongNestingOfIoActions pid =+ applyLabel "shouldCopeWithWrongNestingOfIoActions" $+ runMiddlewareTest+ pid+ "wrong-nesting"+ []+ (applyConcat [rootEntryAsserts, asserts "wrong-nesting"]) +runMiddlewareTest ::+ String+ -> String+ -> [Header]+ -> (Span -> [Assertion]) -> IO Test+runMiddlewareTest pid route headers extraAsserts =+ runTest pid (route ++ "?some=query¶meters=1") headers extraAsserts++ runTest :: String -> String -> [Header] -> (Span -> [Assertion]) -> IO Test runTest pid urlPath headers extraAsserts = do response <-@@ -101,7 +122,13 @@ Just entrySpan = maybeEntrySpan Just exitSpan = maybeExitSpan assertAllIO $- (commonAsserts entrySpan exitSpan responseBody from serverTimingValue) +++ (commonAsserts+ entrySpan+ exitSpan+ responseBody+ from+ serverTimingValue+ ) ++ (extraAsserts entrySpan) @@ -218,14 +245,14 @@ ] -asserts :: Span -> [Assertion]-asserts entrySpan =+asserts :: String -> Span -> [Assertion]+asserts route entrySpan = [ assertEqual "entry data" ( Aeson.object [ "http" .= (Aeson.object [ "method" .= ("GET" :: String) , "host" .= ("127.0.0.1:1207" :: String)- , "url" .= ("/api" :: String)+ , "url" .= (("/" ++ route) :: String) , "params" .= ("some=query¶meters=1" :: String) , "status" .= (200 :: Int) ]
test/unit/Instana/SDK/Internal/SpanStackTest.hs view
@@ -15,6 +15,7 @@ import Instana.SDK.Span.RootEntry (RootEntry (RootEntry)) import qualified Instana.SDK.Span.RootEntry as RootEntry import Instana.SDK.Span.Span (Span (..), SpanKind (..))+import qualified Instana.SDK.Span.Span as Span allTests :: Test@@ -56,6 +57,16 @@ , TestLabel "popPopShouldReturnEntry" popPopShouldReturnEntry , TestLabel "popPeekShouldReturnEntry" popPeekShouldReturnEntry , TestLabel "popPopShouldLeaveEmpty" popPopShouldLeaveEmpty+ , TestLabel "mapTopShouldMapEmptyToEmpty" mapTopShouldMapEmptyToEmpty+ , TestLabel "mapTopShouldMapSuppressedToSuppressed"+ mapTopShouldMapSuppressedToSuppressed+ , TestLabel "mapTopShouldApplyFnToEntry" mapTopShouldApplyFnToEntry+ , TestLabel "mapTopShouldApplyFnToExit" mapTopShouldApplyFnToExit+ , TestLabel "mapEntryShouldMapEmptyToEmpty" mapEntryShouldMapEmptyToEmpty+ , TestLabel "mapEntryShouldMapSuppressedToSuppressed"+ mapEntryShouldMapSuppressedToSuppressed+ , TestLabel "mapEntryShouldApplyFnToEntry" mapEntryShouldApplyFnToEntry+ , TestLabel "mapEntryShouldApplyFnToExit" mapEntryShouldApplyFnToExit ] @@ -274,11 +285,93 @@ fst $ SpanStack.pop entryAndExit +mapTopShouldMapEmptyToEmpty :: Test+mapTopShouldMapEmptyToEmpty =+ TestCase $+ assertBool "mapTop maps empty to empty" $+ SpanStack.isEmpty $+ SpanStack.mapTop increaseEc empty+++mapTopShouldMapSuppressedToSuppressed :: Test+mapTopShouldMapSuppressedToSuppressed =+ TestCase $+ assertBool "mapTop maps suppressd to suppressd" $+ SpanStack.isSuppressed $+ SpanStack.mapTop increaseEc suppressed+++mapTopShouldApplyFnToEntry :: Test+mapTopShouldApplyFnToEntry =+ TestCase $+ assertEqual "mapTop should apply the function to the entry"+ (SpanStack.push+ (Entry (RootEntrySpan (rootEntry { RootEntry.errorCount = 1 })))+ empty)+ (SpanStack.mapTop increaseEc entryOnly)+++mapTopShouldApplyFnToExit :: Test+mapTopShouldApplyFnToExit =+ TestCase $+ assertEqual "mapTop should apply the function to the exit"+ (SpanStack.push+ (Exit (exitSpan { ExitSpan.errorCount = 1 }))+ entryOnly+ )+ (SpanStack.mapTop increaseEc entryAndExit)+++mapEntryShouldMapEmptyToEmpty :: Test+mapEntryShouldMapEmptyToEmpty =+ TestCase $+ assertBool "mapEntry maps empty to empty" $+ SpanStack.isEmpty $+ SpanStack.mapEntry increaseEc empty+++mapEntryShouldMapSuppressedToSuppressed :: Test+mapEntryShouldMapSuppressedToSuppressed =+ TestCase $+ assertBool "mapEntry maps suppressd to suppressd" $+ SpanStack.isSuppressed $+ SpanStack.mapEntry increaseEc suppressed+++mapEntryShouldApplyFnToEntry :: Test+mapEntryShouldApplyFnToEntry =+ TestCase $+ assertEqual "mapEntry should apply the function to the entry"+ (SpanStack.push+ (Entry (RootEntrySpan (rootEntry { RootEntry.errorCount = 1 })))+ empty)+ (SpanStack.mapEntry increaseEc entryOnly)+++mapEntryShouldApplyFnToExit :: Test+mapEntryShouldApplyFnToExit =+ TestCase $+ assertEqual+ "mapEntry should apply the function to the entry when an exit is present"+ (SpanStack.push+ (Exit exitSpan)+ (SpanStack.push+ (Entry (RootEntrySpan (rootEntry { RootEntry.errorCount = 1 })))+ empty)+ )+ (SpanStack.mapEntry increaseEc entryAndExit)++ empty :: SpanStack empty = SpanStack.empty +suppressed :: SpanStack+suppressed =+ SpanStack.suppress++ entryOnly :: SpanStack entryOnly = SpanStack.push (Entry entrySpan) $ empty@@ -291,7 +384,11 @@ entrySpan :: EntrySpan entrySpan =- RootEntrySpan $+ RootEntrySpan rootEntry+++rootEntry :: RootEntry+rootEntry = RootEntry { RootEntry.spanAndTraceId = Id.fromString "traceId" , RootEntry.spanName = "test.entry"@@ -315,6 +412,11 @@ , ExitSpan.serviceName = Nothing , ExitSpan.spanData = emptyValue }+++increaseEc :: Span -> Span+increaseEc =+ Span.addToErrorCount 1 emptyValue :: Value