core-telemetry 0.2.9.1 → 0.2.9.3

raw patch · 3 files changed

+46/−25 lines, 3 filesPVP: minor bump suggested

API additions: PVP suggests at least a minor version bump

API changes (from Hackage documentation)

Files

• core-telemetry.cabal +2/−2
• lib/Core/Telemetry/Honeycomb.hs +30/−10
• lib/Core/Telemetry/Observability.hs +14/−13

@@ -1,11 +1,11 @@ cabal-version: 1.18 --- This file has been generated from package.yaml by hpack version 0.35.1.+-- This file has been generated from package.yaml by hpack version 0.35.2. -- -- see: https://github.com/sol/hpack  name:           core-telemetry-version:        0.2.9.1+version:        0.2.9.3 synopsis:       Advanced telemetry description:    This is part of a library to help build command-line programs, both tools and                 longer-running daemons.

@@ -1,3 +1,4 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralisedNewtypeDeriving #-} {-# LANGUAGE ImportQualifiedPost #-}@@ -71,7 +72,9 @@     ) where  import Codec.Compression.GZip qualified as GZip (compress)+import Control.Concurrent (threadDelay) import Control.Concurrent.MVar (modifyMVar_)+import Control.Exception.Base (Exception) import Control.Exception.Safe qualified as Safe (catch, finally, throw) import Control.Monad (forM_) import Core.Data.Clock (Time, getCurrentTimeNanoseconds, unTime)@@ -350,10 +353,15 @@     let b = Builder.lazyByteString x'     Streams.write (Just b) o +data HoneycombProblem = TransientRetry+    deriving (Show)++instance Exception HoneycombProblem+ postEventToHoneycombAPI :: IORef (Maybe Connection) -> Hostname -> ApiKey -> Dataset -> JsonValue -> IO ()-postEventToHoneycombAPI r honeycombHost apikey dataset json = attempt False+postEventToHoneycombAPI r honeycombHost apikey dataset json = attempt (0 :: Int)   where-    attempt retrying = do+    attempt !retry = do         Safe.catch             ( do                 c <- acquireConnection r honeycombHost@@ -363,13 +371,15 @@                 receiveResponse c handler             )             ( \(e :: SomeException) -> do-                -- ideally we don't get here, but if the SSL connection collapses-                -- we will. We retry /once/, and otherwise throw the exception out.+                -- ideally we don't get here, but if the SSL connection+                -- collapses we will, or if Honeycomb is having an outage we+                -- will. We retry a maxium of 9 times (for a total backoff of+                -- 1022 seconds plus individual connection durations).                 cleanupConnection r-                case retrying of+                case retry > 9 of                     False -> do-                        putStrLn "internal: Reconnecting to Honeycomb"-                        attempt True+                        threadDelay (2 ^ retry * 1000000)+                        attempt (retry + 1)                     True -> do                         putStrLn "internal: Failed to re-establish connection to Honeycomb"                         Safe.throw e@@ -403,14 +413,24 @@                                 Just (JsonNumber 202) -> do                                     -- normal response                                     pure ()+                                Just (JsonNumber 500) -> do+                                    -- Honeycomb is experiencing a problem.+                                    -- Note that this was a "500" /inside/ the+                                    -- valid HTTP 200 payload.+                                    putStrLn "internal: 500 returned from Honeycomb, retrying"+                                    Safe.throw TransientRetry+                                Just (JsonNumber codeN) -> do+                                    -- this is more serious+                                    putStrLn ("internal: " ++ show codeN ++ " returned from Honeycomb, discarding")+                                    C.putStrLn body                                 _ -> do                                     -- some other status!-                                    putStrLn "internal: Unexpected status returned;"+                                    putStrLn "internal: Entirely unexpected response returned, discarding"                                     C.putStrLn body                             _ -> putStrLn "internal: wtf?"                     _ -> do-                        putStrLn "internal: Unexpected response from Honeycomb"+                        putStrLn "internal: Completely unknown response from Honeycomb, discarding"                         C.putStrLn body             _ -> do-                putStrLn "internal: Failed to post to Honeycomb"+                putStrLn "internal: Utterly failed to post to Honeycomb"                 debugHandler p i

@@ -168,6 +168,7 @@ import Control.Concurrent.MVar (modifyMVar_, newMVar, readMVar) import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TQueue (writeTQueue)+import Control.Exception qualified as Base (evaluate) import Control.Exception.Safe qualified as Safe import Core.Data.Clock import Core.Data.Structures (Map, emptyMap, insertKeyValue)@@ -203,7 +204,7 @@ -- a bit specific to Honeycomb's very limited data model, but what else is -- there? data MetricValue-    = MetricValue JsonKey JsonValue+    = MetricValue !JsonKey !JsonValue     deriving (Show)  {- |@@ -661,22 +662,21 @@         modifyMVar_             v             ( \datum -> do-                let meta = attachedMetadataFrom datum+                let !meta = attachedMetadataFrom datum                  -- update the map-                let meta' = List.foldl' f meta values+                let !meta' = List.foldl' f meta values                  -- replace the map back into the Datum (and thereby back into the                 -- Context), updating it-                let datum' =-                        datum-                            { attachedMetadataFrom = meta'-                            }-                pure datum'+                Base.evaluate+                    datum+                        { attachedMetadataFrom = meta'+                        }             )   where     f :: Map JsonKey JsonValue -> MetricValue -> Map JsonKey JsonValue-    f acc (MetricValue k@(JsonKey text) v) =+    f !acc (MetricValue !k@(JsonKey text) !v) =         if nullRope text             then error "Empty metric field name not allowed"             else insertKeyValue k v acc@@ -711,12 +711,13 @@         let v = currentDatumFrom context         datum <- readMVar v -        let meta = attachedMetadataFrom datum+        let !meta = attachedMetadataFrom datum          -- update the map-        let meta' = List.foldl' f meta values+        let !meta' = List.foldl' f meta values         -- replace the map back into the Datum and queue for sending-        let datum' =+        datum' <-+            Base.evaluate                 datum                     { spanNameFrom = label                     , spanIdentifierFrom = Nothing@@ -730,7 +731,7 @@             writeTQueue tel (Just datum')   where     f :: Map JsonKey JsonValue -> MetricValue -> Map JsonKey JsonValue-    f acc (MetricValue k@(JsonKey text) v) =+    f !acc (MetricValue !k@(JsonKey text) !v) =         if nullRope text             then error "Empty metric field name not allowed"             else insertKeyValue k v acc