diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,30 @@ +# 0.4.0.1 + +- Require `nri-prelude >= 0.7.0.0` + +# 0.3.0.1 + +- Support GHC 9.10.2, GHC 9.12.2 +- Drop support for GHC 9.4.x + +# 0.3.0.0 + +- Drop support for GHC 9.2.x +- Support GHC 9.8.3, `bytestring-0.12.x.x`, `text-2.1.x`, `aeson-2.2.x.x` + +# 0.2.0.1 + +- Drop support for `aeson-1.x` +- Support GHC 9.6.5 + +# 0.2.0.0 + +- Drop support for GHC 8.10.7 + +# 0.1.1.5 + +- Support GHC 9.4.7, `aeson-2.1.x` + # 0.1.1.4 - Relax version bounds to encompass `text-2.0.x`, `base-4.16.x` and `template-haskell-2.18.x` diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,6 +1,6 @@ BSD 3-Clause License -Copyright (c) 2022, NoRedInk +Copyright (c) 2026, NoRedInk All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/nri-observability.cabal b/nri-observability.cabal --- a/nri-observability.cabal +++ b/nri-observability.cabal @@ -1,11 +1,11 @@ cabal-version: 1.18 --- This file has been generated from package.yaml by hpack version 0.34.5. +-- This file has been generated from package.yaml by hpack version 0.37.0. -- -- see: https://github.com/sol/hpack name: nri-observability -version: 0.1.1.4 +version: 0.4.0.1 synopsis: Report log spans collected by nri-prelude. description: Please see the README at . category: Web @@ -13,7 +13,7 @@ bug-reports: https://github.com/NoRedInk/haskell-libraries/issues author: NoRedInk maintainer: haskell-open-source@noredink.com -copyright: 2022 NoRedInk Corp. +copyright: 2026 NoRedInk Corp. license: BSD3 license-file: LICENSE build-type: Simple @@ -65,32 +65,80 @@ TypeOperators ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wpartial-fields -Wredundant-constraints -Wincomplete-uni-patterns -fplugin=NriPrelude.Plugin build-depends: - aeson >=1.4.6.0 && <2.1 + aeson >=2.0 && <2.3 , aeson-pretty >=0.8.0 && <0.9 , async >=2.2.2 && <2.3 - , base >=4.12.0.0 && <4.17 + , base >=4.18 && <4.22 , bugsnag-hs >=0.1.0.0 && <0.3 - , bytestring >=0.10.8.2 && <0.12 + , bytestring >=0.10.8.2 && <0.13 , conduit >=1.3.0 && <1.4 , directory >=1.3.3.0 && <1.4 , hostname ==1.0.* , http-client >=0.6.0 && <0.8 , http-client-tls >=0.3.0 && <0.4 - , nri-env-parser >=0.1.0.0 && <0.2 - , nri-prelude >=0.1.0.0 && <0.7 + , nri-env-parser >=0.1.0.0 && <0.5 + , nri-prelude >=0.7.0.0 && <0.8 , random >=1.1 && <1.3 , safe-exceptions >=0.1.7.0 && <1.3 , stm >=2.4 && <2.6 - , text >=1.2.3.1 && <2.1 + , strict-stm >=1.5.0.0 && <1.6 + , text >=1.2.3.1 && <2.2 , time >=1.8.0.2 && <2 , unordered-containers >=0.2.0.0 && <0.3 , uuid >=1.3.0 && <1.4 default-language: Haskell2010 +executable memory-leak-test + main-is: Main.hs + other-modules: + Paths_nri_observability + hs-source-dirs: + scripts/memory-leak-test + default-extensions: + DataKinds + DeriveGeneric + FlexibleContexts + FlexibleInstances + GeneralizedNewtypeDeriving + MultiParamTypeClasses + NamedFieldPuns + NoImplicitPrelude + OverloadedStrings + PartialTypeSignatures + ScopedTypeVariables + Strict + TypeOperators + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wpartial-fields -Wredundant-constraints -Wincomplete-uni-patterns -fplugin=NriPrelude.Plugin -threaded -rtsopts "-with-rtsopts=-N -T" -O2 + build-depends: + aeson >=2.0 && <2.3 + , aeson-pretty >=0.8.0 && <0.9 + , async >=2.2.2 && <2.3 + , base >=4.18 && <4.22 + , bugsnag-hs >=0.1.0.0 && <0.3 + , bytestring >=0.10.8.2 && <0.13 + , conduit >=1.3.0 && <1.4 + , directory >=1.3.3.0 && <1.4 + , hostname ==1.0.* + , http-client >=0.6.0 && <0.8 + , http-client-tls >=0.3.0 && <0.4 + , nri-env-parser >=0.1.0.0 && <0.5 + , nri-observability + , nri-prelude >=0.7.0.0 && <0.8 + , random >=1.1 && <1.3 + , safe-exceptions >=0.1.7.0 && <1.3 + , stm >=2.4 && <2.6 + , strict-stm >=1.5.0.0 && <1.6 + , text >=1.2.3.1 && <2.2 + , time >=1.8.0.2 && <2 + , unordered-containers >=0.2.0.0 && <0.3 + , uuid >=1.3.0 && <1.4 + default-language: Haskell2010 + test-suite tests type: exitcode-stdio-1.0 main-is: Main.hs other-modules: + GoldenHelpers Spec.Observability Spec.Platform.Timer Spec.Reporter.Bugsnag @@ -134,23 +182,24 @@ ExtendedDefaultRules ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wpartial-fields -Wredundant-constraints -Wincomplete-uni-patterns -fplugin=NriPrelude.Plugin -threaded -rtsopts "-with-rtsopts=-N -T" -fno-warn-type-defaults build-depends: - aeson >=1.4.6.0 && <2.1 + aeson >=2.0 && <2.3 , aeson-pretty >=0.8.0 && <0.9 , async >=2.2.2 && <2.3 - , base >=4.12.0.0 && <4.17 + , base >=4.18 && <4.22 , bugsnag-hs >=0.1.0.0 && <0.3 - , bytestring >=0.10.8.2 && <0.12 + , bytestring >=0.10.8.2 && <0.13 , conduit >=1.3.0 && <1.4 , directory >=1.3.3.0 && <1.4 , hostname ==1.0.* , http-client >=0.6.0 && <0.8 , http-client-tls >=0.3.0 && <0.4 - , nri-env-parser >=0.1.0.0 && <0.2 - , nri-prelude >=0.1.0.0 && <0.7 + , nri-env-parser >=0.1.0.0 && <0.5 + , nri-prelude >=0.7.0.0 && <0.8 , random >=1.1 && <1.3 , safe-exceptions >=0.1.7.0 && <1.3 , stm >=2.4 && <2.6 - , text >=1.2.3.1 && <2.1 + , strict-stm >=1.5.0.0 && <1.6 + , text >=1.2.3.1 && <2.2 , time >=1.8.0.2 && <2 , unordered-containers >=0.2.0.0 && <0.3 , uuid >=1.3.0 && <1.4 diff --git a/scripts/memory-leak-test/Main.hs b/scripts/memory-leak-test/Main.hs new file mode 100644 --- /dev/null +++ b/scripts/memory-leak-test/Main.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedRecordUpdate #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import qualified Conduit +import Control.Concurrent (threadDelay) +import Control.Concurrent.Async (mapConcurrently_) +import Control.Monad (forM_, sequence, void) +import Data.List (splitAt) +import qualified Environment +import GHC.Conc (numCapabilities) +import qualified Observability +import qualified Platform +import qualified Process +import Prelude (IO, div, fromIntegral, mapM_, pure, putStrLn, show) + +threads :: Int +threads = fromIntegral numCapabilities + +main :: IO () +main = do + settings' <- Environment.decode Observability.decoder + putStrLn (show settings'.enabledReporters) + let ids = [1 .. 12] |> List.map Text.fromInt + Conduit.withAcquire (Observability.handler settings') <| \handler -> do + forM_ [1 .. (floor (1_000_000 / fromIntegral threads))] <| \n -> do + runRequests handler ids + +runRequests :: Observability.Handler -> [Text] -> IO () +runRequests handler = + mapConcurrently_ + ( \requestId -> do + Platform.rootTracingSpanIO + requestId + Platform.silentTrack + (handler.report requestId) + ("Running task" ++ requestId) + ( \log -> do + Task.perform + log + ( do + Process.sleep 5 + Task.succeed () + ) + ) + ) + +chunks :: Int -> [a] -> [[a]] +chunks _ [] = [] +chunks n xs = + let (ys, zs) = splitAt (fromIntegral n) xs + in ys : chunks n zs diff --git a/src/Log/Kafka.hs b/src/Log/Kafka.hs --- a/src/Log/Kafka.hs +++ b/src/Log/Kafka.hs @@ -7,6 +7,7 @@ topic, partitionId, key, + offset, contents, createTime, logAppendTime, @@ -41,6 +42,8 @@ -- that messages with the same key are guaranteed to end up in the same -- partition. key :: Maybe Text, + -- | The message offset into the partition + offset :: Maybe Int, -- | The contents of the message. contents :: Maybe Contents, -- | The time at which this message was created by a producer. @@ -77,6 +80,7 @@ { topic = Nothing, partitionId = Nothing, key = Nothing, + offset = Nothing, contents = Nothing, createTime = Nothing, logAppendTime = Nothing, @@ -117,5 +121,5 @@ -- > instance Aeson.ToJSON MyMessagePayload -- > -- > contents = mkContents MyMessagePayload { counter = 5 } -mkContents :: Aeson.ToJSON a => a -> Contents +mkContents :: (Aeson.ToJSON a) => a -> Contents mkContents = Contents diff --git a/src/Observability.hs b/src/Observability.hs --- a/src/Observability.hs +++ b/src/Observability.hs @@ -1,4 +1,5 @@ {-# LANGUAGE GADTs #-} +{-# LANGUAGE NumericUnderscores #-} -- | A module dedicated to observability, that is reporting information about -- what the program is doing in production to help us debugging it. @@ -20,7 +21,11 @@ where import qualified Conduit +import Control.Concurrent.Async (async) +import Control.Concurrent.Class.MonadSTM.Strict (atomically, check) +import Control.Concurrent.Class.MonadSTM.Strict.TVar (modifyTVar, newTVarIO, readTVar) import qualified Control.Exception.Safe as Exception +import Control.Monad (void) import qualified Data.Aeson as Aeson import qualified Environment import qualified List @@ -30,8 +35,10 @@ import qualified Reporter.File as File import qualified Reporter.Honeycomb as Honeycomb import qualified Set +import qualified System.Mem as Mem +import qualified System.Timeout as Timeout import qualified Text -import Prelude (pure, traverse) +import Prelude (flip, pure, traverse) import qualified Prelude -- | A handler for reporting to logging/monitoring/observability platforms. @@ -52,8 +59,58 @@ firstReporter : otherReporters -> do firstHandler <- toHandler reportNothingHandler settings firstReporter otherHandlers <- traverse (toHandler firstHandler settings) otherReporters - Prelude.pure (Prelude.mconcat (firstHandler : otherHandlers)) + let innerHandler = Prelude.mconcat (firstHandler : otherHandlers) + reportCounter <- Conduit.liftIO <| newTVarIO (0 :: Int) + Conduit.mkAcquire + ( Prelude.pure <| + Handler + ( \requestId span -> do + atomically (modifyTVar reportCounter (+ 1)) + + -- Spawning a separate thread for the reporting logic ensures the main request + -- thread doesn't need to wait with responding to the user until reporting + -- logic finishes. It also ensures exceptions thrown in reporting logic won't + -- result in failure responses to requests. + void <| async <| do + -- Setting an allocation limit helps protect us from reporting logic using + -- lots of CPU time and negatively affecting application performance. + Mem.setAllocationCounter reportingAllocationLimitInBytes + Mem.enableAllocationLimit + + report innerHandler requestId span + -- This thread is spawned without anybody watching how it does. We set a + -- maximum running time here to ensure it eventually completes. + |> Timeout.timeout reportingTimeoutInMicroSeconds + |> (flip Exception.finally) (atomically <| modifyTVar reportCounter (+ (-1))) + ) + ) + ( \_ -> do + -- Wait for all reporting threads to finish before cleaning up. + atomically <| do + count <- readTVar reportCounter + check (count == 0) + ) + +-- | The maximum amount of bytes the reporting logic is allowed to allocate. +-- Note that this is more of a limit on CPU time then maximum live memory. See +-- the documentation on `setAllocationCounter` for more details: +-- +-- https://hackage.haskell.org/package/base-4.14.0.0/docs/System-Mem.html#v:enableAllocationLimit +-- +-- The current value is a somewhat arbitrary initial value, intentionally not +-- very strict. The hope is experience will help us tighten this value a bit. +reportingAllocationLimitInBytes :: Int +reportingAllocationLimitInBytes = 1024 * 1024 * 1024 + +-- | The maximum amount of time reporting logic is allowed to run for a single +-- request. +-- +-- The current value is a somewhat arbitrary initial value, intentionally not +-- very strict. The hope is experience will help us tighten this value a bit. +reportingTimeoutInMicroSeconds :: Prelude.Int +reportingTimeoutInMicroSeconds = 5_000_000 + reportNothingHandler :: Handler reportNothingHandler = Handler (\_ _ -> Prelude.pure ()) @@ -149,6 +206,9 @@ reporterReport :: handler -> Text -> Platform.TracingSpan -> Prelude.IO () } -> Reporter + +instance Prelude.Show Reporter where + show reporter = "Reporter { name: " ++ Text.toList (reporterName reporter) ++ " }" -- | A list containing all the reporters we support. Reporters are ordered in -- increasing chance of failure, so we can pick the safest one for reporting on diff --git a/src/Platform/AesonHelpers.hs b/src/Platform/AesonHelpers.hs --- a/src/Platform/AesonHelpers.hs +++ b/src/Platform/AesonHelpers.hs @@ -1,24 +1,4 @@ -{-# LANGUAGE CPP #-} - --- | This module supports working with aeson objects in a way compatible with --- both the 1.x and 2.x versions of the aseon library. --- --- Aeson has a Value type for representing JSON values. The Value type has --- constructors for JSON strings, numbers, arrays, and objects. Aeson represents --- JSON objects using an Object type, which in versions 1.x of aeson is a type --- alias for a HashMap. Version 2.x of library make Object an opaque type. --- --- nri-observability needs to perform some operations on JSON objects. Depending --- on which version of aeson we got, we need to use different functions to --- perform these operations. This module contains implementations for both 1.x --- and 2.x versions of Aeson, and automatically picks the right version --- depending on which version of the library is detected. --- --- Once we're done supporting versions 1.x of aeson we can drop this module and --- inline the 2.x versions of functions wherever they are called. -module Platform.AesonHelpers (foldObject, mergeObjects) where - -#if MIN_VERSION_aeson(2,0,0) +module Platform.AesonHelpers (foldObject, singleton) where import qualified Data.Aeson as Aeson import qualified Data.Aeson.Key as Key @@ -27,26 +7,5 @@ foldObject :: (Text -> Aeson.Value -> acc -> acc) -> acc -> Aeson.Object -> acc foldObject fn = KeyMap.foldrWithKey (\key val acc -> fn (Key.toText key) val acc) -mergeObjects :: - (Aeson.Value -> Aeson.Value -> Aeson.Value) -> - Aeson.Object -> - Aeson.Object -> - Aeson.Object -mergeObjects = KeyMap.unionWith - -#else - -import qualified Data.Aeson as Aeson -import qualified Data.HashMap.Strict as HashMap - -foldObject :: (Text -> Aeson.Value -> acc -> acc) -> acc -> Aeson.Object -> acc -foldObject = HashMap.foldrWithKey - -mergeObjects :: - (Aeson.Value -> Aeson.Value -> Aeson.Value) -> - Aeson.Object -> - Aeson.Object -> - Aeson.Object -mergeObjects merge object1 object2 = HashMap.unionWith merge object1 object2 - -#endif +singleton :: Text -> Aeson.Value -> Aeson.Object +singleton key = KeyMap.singleton (Key.fromText key) diff --git a/src/Platform/ReporterHelpers.hs b/src/Platform/ReporterHelpers.hs --- a/src/Platform/ReporterHelpers.hs +++ b/src/Platform/ReporterHelpers.hs @@ -28,7 +28,7 @@ -- , ("treasure.coords.y", "14" ) -- , ("treasure.worth" , "Tons!") -- ] -toHashMap :: Aeson.ToJSON a => a -> HashMap.HashMap Text Text +toHashMap :: (Aeson.ToJSON a) => a -> HashMap.HashMap Text Text toHashMap x = case Aeson.toJSON x of Aeson.Object object -> diff --git a/src/Reporter/Bugsnag/Internal.hs b/src/Reporter/Bugsnag/Internal.hs --- a/src/Reporter/Bugsnag/Internal.hs +++ b/src/Reporter/Bugsnag/Internal.hs @@ -7,6 +7,8 @@ import qualified Control.Exception.Safe as Exception import Data.Aeson ((.=)) import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Key as Key +import qualified Data.Aeson.KeyMap as KeyMap import qualified Data.HashMap.Strict as HashMap import qualified Data.List import qualified Data.Proxy as Proxy @@ -131,7 +133,7 @@ "request id" .= requestId ] |> Aeson.object - |> HashMap.singleton "request" + |> AesonHelpers.singleton "request" -- | Find the most recently started span that failed. This span is closest to -- the failure and we'll use the data in it and its parents to build the @@ -273,7 +275,9 @@ case Platform.frame span of Nothing -> Nothing Just (_, frame) -> - Stack.srcLocFile frame ++ ":" ++ Prelude.show (Stack.srcLocStartLine frame) + Stack.srcLocFile frame + ++ ":" + ++ Prelude.show (Stack.srcLocStartLine frame) |> Text.fromList |> HashMap.singleton "stack frame" |> Just @@ -363,7 +367,7 @@ event { Bugsnag.event_metaData = Aeson.toJSON details - |> HashMap.singleton (Platform.name span) + |> AesonHelpers.singleton (Platform.name span) |> Just |> (++) (Bugsnag.event_metaData event) } @@ -373,24 +377,24 @@ event { Bugsnag.event_metaData = Aeson.toJSON details - |> HashMap.singleton "custom" - |> HashMap.unionWith + |> AesonHelpers.singleton "custom" + |> KeyMap.unionWith mergeJson - (Bugsnag.event_metaData event |> Maybe.withDefault HashMap.empty) + (Bugsnag.event_metaData event |> Maybe.withDefault KeyMap.empty) |> Just } mergeJson :: Aeson.Value -> Aeson.Value -> Aeson.Value -mergeJson (Aeson.Object x) (Aeson.Object y) = Aeson.Object (AesonHelpers.mergeObjects mergeJson x y) +mergeJson (Aeson.Object x) (Aeson.Object y) = Aeson.Object (KeyMap.unionWith mergeJson x y) mergeJson _ last = last mergeMetaData :: - Maybe (HashMap.HashMap Text Aeson.Value) -> - Maybe (HashMap.HashMap Text Aeson.Value) -> - Maybe (HashMap.HashMap Text Aeson.Value) + Maybe Aeson.Object -> + Maybe Aeson.Object -> + Maybe Aeson.Object mergeMetaData Nothing x = x mergeMetaData x Nothing = x -mergeMetaData (Just x) (Just y) = Just (HashMap.unionWith mergeJson x y) +mergeMetaData (Just x) (Just y) = Just (KeyMap.unionWith mergeJson x y) renderIncomingHttpRequest :: Bugsnag.Event -> @@ -415,14 +419,14 @@ Bugsnag.event_metaData = mergeMetaData (Bugsnag.event_metaData event) - ( [ "endpoint" .= HttpRequest.endpoint request, - "http version" .= HttpRequest.httpVersion request, - "response status" .= HttpRequest.status request, - "path" .= HttpRequest.path request, - "query string" .= HttpRequest.queryString request + ( [ Key.fromText "endpoint" .= HttpRequest.endpoint request, + Key.fromText "http version" .= HttpRequest.httpVersion request, + Key.fromText "response status" .= HttpRequest.status request, + Key.fromText "path" .= HttpRequest.path request, + Key.fromText "query string" .= HttpRequest.queryString request ] |> Aeson.object - |> HashMap.singleton "request" + |> AesonHelpers.singleton "request" |> Just ) } @@ -463,7 +467,7 @@ Bugsnag.stackFrame_inProject = Just True } -typeName :: forall a. Typeable.Typeable a => a -> Text +typeName :: forall a. (Typeable.Typeable a) => a -> Text typeName _ = Typeable.typeRep (Proxy.Proxy :: Proxy.Proxy a) |> Prelude.show diff --git a/src/Reporter/Dev/Internal.hs b/src/Reporter/Dev/Internal.hs --- a/src/Reporter/Dev/Internal.hs +++ b/src/Reporter/Dev/Internal.hs @@ -6,7 +6,6 @@ import qualified Control.Concurrent.Async as Async import qualified Control.Concurrent.MVar as MVar import qualified Control.Exception.Safe as Exception -import qualified Data.Text.IO import qualified Data.Text.Lazy import qualified Data.Text.Lazy.Builder as Builder import qualified Log.HttpRequest as HttpRequest @@ -77,7 +76,8 @@ -- is empty. We have a logging thread running separately that takes logs -- from the MVar and prints them to stdout one at a time. writeLock :: MVar.MVar Builder.Builder, - loggingThread :: Async.Async () + loggingThread :: Async.Async (), + advertiseLogExplorer :: Async.Async () } -- | Create a 'Handler'. Do this once when your application starts and reuse @@ -87,8 +87,9 @@ writeLock <- MVar.newEmptyMVar counter <- MVar.newMVar 0 loggingThread <- Async.async (logLoop counter writeLock) + advertiseLogExplorer <- Async.async (advertiseLoop counter Nothing) timer <- Timer.mkTimer - Prelude.pure Handler {timer, writeLock, loggingThread} + Prelude.pure Handler {timer, writeLock, loggingThread, advertiseLogExplorer} -- | Clean up your handler after you're done with it. Call this before your -- application shuts down. @@ -102,15 +103,28 @@ line <- MVar.takeMVar lock Builder.toLazyText line |> Data.Text.Lazy.toStrict - |> Data.Text.IO.putStrLn - ownCount <- MVar.modifyMVar counter (\n -> Prelude.pure (n + 1, n + 1)) - Async.concurrently_ - (logLoop counter lock) - ( do - -- After a few seconds of inactivity, advertise for log-explorer. - Control.Concurrent.threadDelay 3_000_000 {- 3 seconds -} - currentCount <- MVar.readMVar counter - if ownCount == currentCount - then Prelude.putStrLn "🕵️ Need more detail? Try running the `log-explorer` command!\n" - else Prelude.pure () - ) + |> putTextLn + MVar.modifyMVar_ counter (\n -> Prelude.pure (n + 1)) + logLoop counter lock + +advertiseLoop :: MVar.MVar Int -> Maybe Int -> Prelude.IO () +advertiseLoop counter lastAdvertisedCount = do + lastCount <- MVar.readMVar counter + Control.Concurrent.threadDelay 3_000_000 {- 3 seconds -} + currentCount <- MVar.readMVar counter + if shouldAdvertise lastCount currentCount lastAdvertisedCount + then do + putTextLn "🕵️ Need more detail? Try running the `log-explorer` command!\n" + advertiseLoop counter (Just currentCount) + else advertiseLoop counter lastAdvertisedCount + +shouldAdvertise :: Int -> Int -> Maybe Int -> Bool +shouldAdvertise lastCount currentCount lastAdvertisedCount = + let -- we don't want to advertise on launch + justLaunched = lastAdvertisedCount == Nothing && currentCount == 0 + -- if after N seconds the count hasn't changed, we've stopped logging for a bit + stoppedLogging = lastCount == currentCount + -- we don't want to advertise multiple times while we're idle + alreadyAdvertised = + lastAdvertisedCount == Just currentCount + in stoppedLogging && not alreadyAdvertised && not justLaunched diff --git a/src/Reporter/File/Internal.hs b/src/Reporter/File/Internal.hs --- a/src/Reporter/File/Internal.hs +++ b/src/Reporter/File/Internal.hs @@ -75,8 +75,8 @@ ) ++ (Aeson..=) "allocated_mb" (toFloat (Platform.allocated span) / 1e6) ++ (Aeson..=) "details" (Platform.details span) - |> Aeson.pairs - |> Data.Aeson.Encoding.encodingToLazyByteString + |> Aeson.pairs + |> Data.Aeson.Encoding.encodingToLazyByteString -- | Contextual information this reporter needs to do its work. You can create -- one using 'handler'. diff --git a/src/Reporter/Honeycomb/Internal.hs b/src/Reporter/Honeycomb/Internal.hs --- a/src/Reporter/Honeycomb/Internal.hs +++ b/src/Reporter/Honeycomb/Internal.hs @@ -137,7 +137,8 @@ -- https://www.wolframalpha.com/input/?i=plot+1%2Fmax%281%2F1000%2C+min%281%2C+%281%2F1000%29+*+%281.5+%5E+%28x+%2F+30%29%29%29%29+from+x%3D1+to+x%3D300 sampleRateForDuration :: Float -> Float -> Float -> Float sampleRateForDuration baseRate requestDurationMs apdexTMs = - baseRate * (1.5 ^ (requestDurationMs / apdexTMs)) + baseRate + * (1.5 ^ (requestDurationMs / apdexTMs)) |> clamp baseRate 1 calculateApdex :: Settings -> Platform.TracingSpan -> Float @@ -221,6 +222,7 @@ |> addField "duration_ms" (Prelude.fromIntegral duration / 1000) |> addField "allocated_bytes" (Platform.allocated span) |> addField "failed" isError + |> addField "contains_failures" (Platform.containsFailures span) |> addField "source_location" sourceLocation |> addDetails span |> addEndpoint @@ -230,8 +232,8 @@ { batchevent_time = timestamp, batchevent_data = hcSpan, batchevent_samplerate = sampleRate sharedTraceData - } : - children + } + : children ) data Stats = Stats @@ -442,7 +444,7 @@ deriving (Aeson.ToJSON, Show) data JsonEncodable where - JsonEncodable :: Aeson.ToJSON a => a -> JsonEncodable + JsonEncodable :: (Aeson.ToJSON a) => a -> JsonEncodable instance Aeson.ToJSON JsonEncodable where toEncoding (JsonEncodable x) = Aeson.toEncoding x @@ -454,7 +456,7 @@ emptySpan :: Span emptySpan = Span Dict.empty -addField :: Aeson.ToJSON a => Text -> a -> Span -> Span +addField :: (Aeson.ToJSON a) => Text -> a -> Span -> Span addField key val (Span span) = Span (Dict.insert key (JsonEncodable val) span) newtype SpanId = SpanId Text @@ -480,11 +482,15 @@ http <- HTTP.TLS.getGlobalManager revision <- getRevision hostname' <- Network.HostName.getHostName - let baseSpan = + let baseSpan' = emptySpan |> addField "service_name" (serviceName settings) |> addField "hostname" (Text.fromList hostname') |> addField "revision" revision + let baseSpan = + case k8sNode settings of + Nothing -> baseSpan' + Just node -> addField "k8s_node" node baseSpan' Prelude.pure Handler { http = http, @@ -503,19 +509,18 @@ -- is basing it off of time of day) so we sample less at low traffic (skipLogging, sampleRate) <- - case Platform.succeeded span of - Platform.Succeeded -> do + if Platform.containsFailures span + then Prelude.pure (False, 1) + else do let probability = deriveSampleRate span settings roll <- Random.randomRIO (0.0, 1.0) Prelude.pure (roll > probability, round (1 / probability)) - Platform.Failed -> Prelude.pure (False, 1) - Platform.FailedWith _ -> Prelude.pure (False, 1) uuid <- Data.UUID.V4.nextRandom if skipLogging then Prelude.pure SampledOut else - Prelude.pure - <| SendToHoneycomb + Prelude.pure <| + SendToHoneycomb SharedTraceData { timer, sampleRate, @@ -585,7 +590,11 @@ -- application, for example if a path is significantly lower volume than -- another the apdex may require tuning. -- [@default value@] the input int - modifyApdexTimeMs :: Int -> Platform.TracingSpan -> Int + modifyApdexTimeMs :: Int -> Platform.TracingSpan -> Int, + -- | When not @Nothing@, an extra @k8s_label@ label is applied to every logged + -- span. + -- [@default value@] Nothing + k8sNode :: Maybe Text } -- | Read 'Settings' from environment variables. Default variables will be used @@ -600,6 +609,7 @@ |> andMap apdexTimeMsDecoder |> andMap (Prelude.pure always) |> andMap (Prelude.pure always) + |> andMap k8sNodeDecoder honeycombApiKeyDecoder :: Environment.Decoder (Log.Secret ByteString.ByteString) honeycombApiKeyDecoder = @@ -650,3 +660,17 @@ Environment.defaultValue = "100" } Environment.int + +k8sNodeDecoder :: Environment.Decoder (Maybe Text) +k8sNodeDecoder = + Environment.variable + Environment.Variable + { Environment.name = "HONEYCOMB_K8S_NODE", + Environment.description = "The Kubernetes node this service instance is running on.", + Environment.defaultValue = "" + } + ( Environment.custom Environment.text <| \str -> + if Text.isEmpty str + then Ok Nothing + else Ok (Just str) + ) diff --git a/tests/GoldenHelpers.hs b/tests/GoldenHelpers.hs new file mode 100644 --- /dev/null +++ b/tests/GoldenHelpers.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} + +module GoldenHelpers (goldenResultsDir) where + +-- | Historical context: +-- Golden results are slightly different between GHC 9.2.x and 8.10.x due +-- to apparent differences in internal handling of stack frame source locations. +-- In particular, the end of a function call now does not extend to the end of +-- the line but instead to the end of the function name. E.g. for the following: +-- +-- > foo +-- > bar +-- > baz +-- +-- In GHC 8.10.x (and possibly GHC 9.0.x?) `srcLocEndLine` and `srcLocEndCol` +-- would correspond to the `z` at the end of `baz`. Unfortunately, in GHC 9.2.x +-- it corresponds to the second `o` at the end of `foo`. +-- +-- In GHC 9.10.x, stack trace output formatting is a little different. +-- +-- We keep this helper around so that if this happens again for future GHC versions +-- we can have different golden results for different GHC versions as necessary. +goldenResultsDir :: Text + +# if __GLASGOW_HASKELL__ == 910 +goldenResultsDir = "tests/golden-results-9.10" +# else +-- seems to be fine for ghc 9.12? +goldenResultsDir = "tests/golden-results-9.8" +# endif diff --git a/tests/Spec/Observability.hs b/tests/Spec/Observability.hs --- a/tests/Spec/Observability.hs +++ b/tests/Spec/Observability.hs @@ -22,11 +22,10 @@ let reporter2 = fakeReporter (\_ -> appendLog "reporter2" log) let settings = settings' {Observability.enabledReporters = [reporter1, reporter2]} reports <- - Expect.fromIO - ( Conduit.withAcquire (Observability.handler settings) <| \handler -> do - Observability.report handler "request-id-1234" emptyTracingSpan - IORef.readIORef log - ) + Expect.fromIO <| do + Conduit.withAcquire (Observability.handler settings) <| \handler -> do + Observability.report handler "request-id-1234" emptyTracingSpan + IORef.readIORef log reports |> Expect.equal ["reporter1", "reporter2"], test "The first reporter reports sync exceptions thrown by the other reporters" <| \_ -> do @@ -36,11 +35,10 @@ let reporter2 = fakeReporter (\_ -> Exception.throwString "failed!") let settings = settings' {Observability.enabledReporters = [reporter1, reporter2]} reports <- - Expect.fromIO - ( Conduit.withAcquire (Observability.handler settings) <| \handler -> do - Observability.report handler "request-id-1234" emptyTracingSpan - IORef.readIORef log - ) + Expect.fromIO <| do + Conduit.withAcquire (Observability.handler settings) <| \handler -> do + Observability.report handler "request-id-1234" emptyTracingSpan + IORef.readIORef log reports |> Expect.equal ["reporter1: example", "reporter1: Failed to report span to fake"], test "The first reporter reports async exceptions thrown by the other reporters" <| \_ -> do @@ -55,8 +53,10 @@ ) let settings = settings' {Observability.enabledReporters = [reporter1, reporter2]} reports <- - Expect.fromIO <| Conduit.withAcquire (Observability.handler settings) <| \handler -> do - Observability.report handler "request-id-1234" emptyTracingSpan + Expect.fromIO <| do + ( Conduit.withAcquire (Observability.handler settings) <| \handler -> do + Observability.report handler "request-id-1234" emptyTracingSpan + ) |> Exception.handleAsync (\(Exception.AsyncExceptionWrapper _) -> Prelude.pure ()) IORef.readIORef log reports @@ -69,11 +69,10 @@ let reporter3 = fakeReporter (\span -> appendLog ("reporter3: " ++ Platform.name span) log) let settings = settings' {Observability.enabledReporters = [reporter1, reporter2, reporter3]} reports <- - Expect.fromIO - ( Conduit.withAcquire (Observability.handler settings) <| \handler -> do - Observability.report handler "request-id-1234" emptyTracingSpan - IORef.readIORef log - ) + Expect.fromIO <| do + Conduit.withAcquire (Observability.handler settings) <| \handler -> do + Observability.report handler "request-id-1234" emptyTracingSpan + IORef.readIORef log reports |> Expect.equal ["reporter1: example", "reporter1: Failed to report span to fake", "reporter3: example"] ] diff --git a/tests/Spec/Reporter/Bugsnag.hs b/tests/Spec/Reporter/Bugsnag.hs --- a/tests/Spec/Reporter/Bugsnag.hs +++ b/tests/Spec/Reporter/Bugsnag.hs @@ -9,6 +9,7 @@ import qualified Dict import qualified Expect import qualified GHC.Stack as Stack +import GoldenHelpers (goldenResultsDir) import qualified Log import qualified Log.HttpRequest as HttpRequest import qualified Log.RedisCommands as RedisCommands @@ -441,4 +442,4 @@ |> Data.Aeson.Encode.Pretty.encodePretty |> Data.ByteString.Lazy.toStrict |> Data.Text.Encoding.decodeUtf8 - |> Expect.equalToContentsOf ("tests/golden-results/" ++ filename ++ ".json") + |> Expect.equalToContentsOf (goldenResultsDir ++ "/" ++ filename ++ ".json") diff --git a/tests/Spec/Reporter/Dev.hs b/tests/Spec/Reporter/Dev.hs --- a/tests/Spec/Reporter/Dev.hs +++ b/tests/Spec/Reporter/Dev.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + module Spec.Reporter.Dev (tests) where import qualified Control.Exception.Safe as Exception @@ -5,6 +7,7 @@ import qualified Data.Text.Lazy.Builder import qualified Data.Time.LocalTime as LocalTime import qualified Expect +import GoldenHelpers (goldenResultsDir) import qualified Log.HttpRequest as HttpRequest import qualified Platform import qualified Platform.Timer as Timer @@ -16,36 +19,42 @@ tests = Test.describe "Observability.Dev" - [ logTest - "log span without details or children" - emptyTracingSpan - { Platform.name = "root-span", - Platform.started = ms 5 - }, - logTest - "log span with exception" - emptyTracingSpan - { Platform.name = "root-span", - Platform.succeeded = Platform.FailedWith (Exception.SomeException (CustomException "toast!")) - }, - logTest - "logs information about an incoming http request" - emptyTracingSpan - { Platform.details = - HttpRequest.emptyDetails - { HttpRequest.endpoint = Just "/hats/:hat_id" - } - |> HttpRequest.Incoming - |> Platform.toTracingSpanDetails - |> Just - } + [ Test.describe "log tests" logTests, + Test.describe "advertise tests" advertiseTests ] +logTests :: [Test.Test] +logTests = + [ logTest + "log span without details or children" + emptyTracingSpan + { Platform.name = "root-span", + Platform.started = ms 5 + }, + logTest + "log span with exception" + emptyTracingSpan + { Platform.name = "root-span", + Platform.succeeded = Platform.FailedWith (Exception.SomeException (CustomException "toast!")) + }, + logTest + "logs information about an incoming http request" + emptyTracingSpan + { Platform.details = + HttpRequest.emptyDetails + { HttpRequest.endpoint = Just "/hats/:hat_id" + } + |> HttpRequest.Incoming + |> Platform.toTracingSpanDetails + |> Just + } + ] + logTest :: Text -> Platform.TracingSpan -> Test.Test logTest name span = Test.test name <| \_ -> do let logfile = Text.replace " " "-" name - let logpath = "tests/golden-results/dev-reporter-" ++ logfile + let logpath = goldenResultsDir ++ "/dev-reporter-" ++ logfile span |> Dev.mkLog timer |> Data.Text.Lazy.Builder.toLazyText @@ -74,3 +83,21 @@ Platform.allocated = 0, Platform.children = [] } + +advertiseTests :: [Test.Test] +advertiseTests = + [ Test.test "does not advertises on launch" <| \_ -> do + Dev.shouldAdvertise 0 0 Nothing |> Expect.equal False, + Test.test "does not advertise if still logging (on launch)" <| \_ -> do + Dev.shouldAdvertise 0 10 Nothing |> Expect.equal False, + Test.test "does not advertise if still logging" <| \_ -> do + Dev.shouldAdvertise 0 10 (Just 0) |> Expect.equal False, + Test.test "does not readvertise" <| \_ -> do + Dev.shouldAdvertise 1 1 (Just 1) |> Expect.equal False, + Test.test "does not advertise if still logging (on launch)" <| \_ -> do + Dev.shouldAdvertise 0 10 Nothing |> Expect.equal False, + Test.test "does not advertise if still logging" <| \_ -> do + Dev.shouldAdvertise 0 10 (Just 0) |> Expect.equal False, + Test.test "only advertises if counter hasn't changed and we haven't advertised it yet" <| \_ -> do + Dev.shouldAdvertise 10 10 (Just 0) |> Expect.equal True + ] diff --git a/tests/Spec/Reporter/File.hs b/tests/Spec/Reporter/File.hs --- a/tests/Spec/Reporter/File.hs +++ b/tests/Spec/Reporter/File.hs @@ -9,6 +9,7 @@ import qualified Data.Time.LocalTime as LocalTime import qualified Dict import qualified Expect +import GoldenHelpers (goldenResultsDir) import qualified Log.HttpRequest as HttpRequest import qualified Log.RedisCommands as RedisCommands import qualified Log.SqlQuery as SqlQuery @@ -102,7 +103,7 @@ |> Just }, logTest - "logs information about an outoing http request" + "logs information about an outgoing http request" emptyTracingSpan { Platform.details = HttpRequest.emptyDetails @@ -151,7 +152,8 @@ Ok reEncoded -> Text.join "\n" reEncoded |> Expect.equalToContentsOf - ( Text.fromList "tests/golden-results/file-reporter-" + ( goldenResultsDir + ++ "/file-reporter-" ++ Text.replace " " "-" name ) diff --git a/tests/Spec/Reporter/Honeycomb.hs b/tests/Spec/Reporter/Honeycomb.hs --- a/tests/Spec/Reporter/Honeycomb.hs +++ b/tests/Spec/Reporter/Honeycomb.hs @@ -13,6 +13,7 @@ import qualified Dict import qualified Expect import qualified GHC.Stack as Stack +import GoldenHelpers (goldenResultsDir) import qualified Log import qualified Log.HttpRequest as HttpRequest import qualified Log.Kafka as Kafka @@ -31,7 +32,8 @@ [ test "encodes span marked as failed as an exception" <| \_ -> emptyTracingSpan { Platform.name = "root span", - Platform.succeeded = Platform.Failed + Platform.succeeded = Platform.Failed, + Platform.containsFailures = True } |> toBatchEvents |> encodesTo "honeycomb-failure-without-exception", @@ -46,7 +48,8 @@ emptyTracingSpan { Platform.name = "root span", Platform.succeeded = - Platform.FailedWith (Exception.SomeException (CustomException "something went wrong")) + Platform.FailedWith (Exception.SomeException (CustomException "something went wrong")), + Platform.containsFailures = True } |> toBatchEvents |> encodesTo "honeycomb-failure-with-exception", @@ -54,6 +57,7 @@ emptyTracingSpan { Platform.name = "Incoming HTTP Request", Platform.succeeded = Platform.Failed, + Platform.containsFailures = True, Platform.details = HttpRequest.emptyDetails { HttpRequest.httpVersion = Just "1", @@ -74,11 +78,13 @@ emptyTracingSpan { Platform.name = "Processing Kafka Message", Platform.succeeded = Platform.Failed, + Platform.containsFailures = True, Platform.details = Kafka.emptyDetails { Kafka.topic = Just "topic", Kafka.partitionId = Just 12, Kafka.key = Just "key", + Kafka.offset = Just 1, Kafka.contents = Just (Kafka.mkContents ()), Kafka.createTime = Just (Clock.POSIX.posixSecondsToUTCTime 0), Kafka.logAppendTime = Just (Clock.POSIX.posixSecondsToUTCTime 0), @@ -97,6 +103,7 @@ emptyTracingSpan { Platform.name = "MySQL Query", Platform.succeeded = Platform.Failed, + Platform.containsFailures = True, Platform.details = SqlQuery.emptyDetails { SqlQuery.databaseType = Just SqlQuery.postgresql, @@ -118,6 +125,7 @@ emptyTracingSpan { Platform.name = "Make Redis Query", Platform.succeeded = Platform.Failed, + Platform.containsFailures = True, Platform.details = RedisCommands.emptyDetails { RedisCommands.host = Just "cache.noredink.com", @@ -133,6 +141,7 @@ emptyTracingSpan { Platform.name = "Making HTTP request", Platform.succeeded = Platform.Failed, + Platform.containsFailures = True, Platform.details = HttpRequest.emptyDetails { HttpRequest.host = Just "http://antsonline.com", @@ -148,6 +157,7 @@ test "renders log failures correctly" <| \_ -> emptyTracingSpan { Platform.succeeded = Platform.Failed, + Platform.containsFailures = True, Platform.name = "log message", Platform.details = Log.LogContexts @@ -163,6 +173,7 @@ test "renders withContext failures correctly" <| \_ -> emptyTracingSpan { Platform.succeeded = Platform.Failed, + Platform.containsFailures = True, Platform.name = "some context", Platform.details = Log.LogContexts @@ -182,6 +193,7 @@ emptyTracingSpan { Platform.name = "measure weather", Platform.succeeded = Platform.Failed, + Platform.containsFailures = True, Platform.details = CustomDetails "32 C" |> Platform.toTracingSpanDetails @@ -190,6 +202,7 @@ [ emptyTracingSpan { Platform.name = "measure humidity", Platform.succeeded = Platform.Failed, + Platform.containsFailures = True, Platform.details = CustomDetails "25 %" |> Platform.toTracingSpanDetails @@ -226,9 +239,11 @@ test "de-noises nested log events at enrichment time" <| \_ -> emptyTracingSpan { Platform.name = "root span", + Platform.containsFailures = True, Platform.children = [ emptyTracingSpan { Platform.succeeded = Platform.Failed, + Platform.containsFailures = True, Platform.name = "log message", Platform.details = Log.LogContexts @@ -317,7 +332,7 @@ sampleRates |> (:) ("apdex T: " ++ Text.fromFloat apdexTMs ++ "ms") |> Text.join "\n" - |> Expect.equalToContentsOf "test/golden-results/observability-spec-honeycomb-sampling" + |> Expect.equalToContentsOf (goldenResultsDir ++ "/observability-spec-honeycomb-sampling") ], describe "deriveSampleRate" @@ -401,7 +416,8 @@ Honeycomb.fractionOfSuccessRequestsLogged = 0.0, Honeycomb.apdexTimeMs = 10, Honeycomb.modifyFractionOfSuccessRequestsLogged = always, - Honeycomb.modifyApdexTimeMs = always + Honeycomb.modifyApdexTimeMs = always, + Honeycomb.k8sNode = Nothing } toBatchEvents :: Platform.TracingSpan -> [Honeycomb.BatchEvent] @@ -431,4 +447,4 @@ |> Data.Aeson.Encode.Pretty.encodePretty |> Data.ByteString.Lazy.toStrict |> Data.Text.Encoding.decodeUtf8 - |> Expect.equalToContentsOf ("test/golden-results/" ++ filename ++ ".json") + |> Expect.equalToContentsOf (goldenResultsDir ++ "/" ++ filename ++ ".json")