nri-observability 0.1.1.4 → 0.4.0.1

raw patch · 18 files changed

+433/−161 lines, 18 filesdep +nri-observabilitydep +strict-stmdep ~aesondep ~basedep ~bytestringnew-component:exe:memory-leak-testPVP ok

version bump matches the API change (PVP)

Dependencies added: nri-observability, strict-stm

Dependency ranges changed: aeson, base, bytestring, nri-env-parser, nri-prelude, text

API changes (from Hackage documentation)

Files

• CHANGELOG.md +27/−0
• LICENSE +1/−1
• nri-observability.cabal +64/−15
• scripts/memory-leak-test/Main.hs +55/−0
• src/Log/Kafka.hs +5/−1
• src/Observability.hs +62/−2
• src/Platform/AesonHelpers.hs +3/−44
• src/Platform/ReporterHelpers.hs +1/−1
• src/Reporter/Bugsnag/Internal.hs +22/−18
• src/Reporter/Dev/Internal.hs +29/−15
• src/Reporter/File/Internal.hs +2/−2
• src/Reporter/Honeycomb/Internal.hs +37/−13
• tests/GoldenHelpers.hs +31/−0
• tests/Spec/Observability.hs +16/−17
• tests/Spec/Reporter/Bugsnag.hs +2/−1
• tests/Spec/Reporter/Dev.hs +51/−24
• tests/Spec/Reporter/File.hs +4/−2
• tests/Spec/Reporter/Honeycomb.hs +21/−5

@@ -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`

@@ -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

@@ -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 <https://github.com/NoRedInk/haskell-libraries/tree/trunk/nri-observability#readme>. 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

@@ -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

@@ -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

@@ -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

@@ -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)

@@ -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 ->

@@ -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

@@ -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

@@ -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'.

@@ -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)+    )

@@ -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

@@ -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"]     ]

@@ -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")

@@ -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+  ]

@@ -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             ) 

@@ -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")