diff --git a/core-telemetry.cabal b/core-telemetry.cabal --- a/core-telemetry.cabal +++ b/core-telemetry.cabal @@ -1,11 +1,11 @@ cabal-version: 1.18 --- This file has been generated from package.yaml by hpack version 0.35.0. +-- This file has been generated from package.yaml by hpack version 0.35.1. -- -- see: https://github.com/sol/hpack name: core-telemetry -version: 0.2.7.0 +version: 0.2.7.2 synopsis: Advanced telemetry description: This is part of a library to help build command-line programs, both tools and longer-running daemons. @@ -31,6 +31,8 @@ GHC == 8.10.7 extra-doc-files: HoneycombTraceExample.png + honeycomb-sad-trace.png + honeycomb-happy-trace.png source-repository head type: git @@ -52,7 +54,7 @@ base >=4.11 && <5 , bytestring , core-data >=0.3.8.0 - , core-program >=0.6.1 + , core-program >=0.6.2.2 , core-text >=0.3.7.1 , exceptions , http-streams diff --git a/honeycomb-happy-trace.png b/honeycomb-happy-trace.png new file mode 100644 Binary files /dev/null and b/honeycomb-happy-trace.png differ diff --git a/honeycomb-sad-trace.png b/honeycomb-sad-trace.png new file mode 100644 Binary files /dev/null and b/honeycomb-sad-trace.png differ diff --git a/lib/Core/Telemetry.hs b/lib/Core/Telemetry.hs --- a/lib/Core/Telemetry.hs +++ b/lib/Core/Telemetry.hs @@ -14,28 +14,28 @@ the submodules are mostly there to group documentation, along with grouping the implementations for each of the different supported backends. -} -module Core.Telemetry ( - -- * Traces and Spans +module Core.Telemetry + ( -- * Traces and Spans - -- | - -- Adding observability tracing to your program. - module Core.Telemetry.Observability, + -- | + -- Adding observability tracing to your program. + module Core.Telemetry.Observability - -- * Exporting to backends + -- * Exporting to backends - -- | - -- Processors to export telemetry to a backend. - module Core.Telemetry.Console, - module Core.Telemetry.General, - module Core.Telemetry.Honeycomb, - module Core.Telemetry.Structured, + -- | + -- Processors to export telemetry to a backend. + , module Core.Telemetry.Console + , module Core.Telemetry.General + , module Core.Telemetry.Honeycomb + , module Core.Telemetry.Structured - -- * Internals + -- * Internals - -- | - -- Various helper functions. - module Core.Telemetry.Identifiers -) where + -- | + -- Various helper functions. + , module Core.Telemetry.Identifiers + ) where import Core.Telemetry.Console import Core.Telemetry.General diff --git a/lib/Core/Telemetry/Console.hs b/lib/Core/Telemetry/Console.hs --- a/lib/Core/Telemetry/Console.hs +++ b/lib/Core/Telemetry/Console.hs @@ -18,9 +18,9 @@ precise = 45.0 @ -} -module Core.Telemetry.Console ( - consoleExporter, -) where +module Core.Telemetry.Console + ( consoleExporter + ) where import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TQueue (TQueue, writeTQueue) @@ -74,7 +74,7 @@ <> singletonRope ':' <> let pairs :: [(JsonKey, JsonValue)] pairs = fromMap (attachedMetadataFrom datum) - in List.foldl' f emptyRope pairs + in List.foldl' f emptyRope pairs <> intoEscapes resetColour now <- getCurrentTimeNanoseconds @@ -90,7 +90,8 @@ f :: Rope -> (JsonKey, JsonValue) -> Rope f acc (k, v) = - acc <> "\n " + acc + <> "\n " <> intoEscapes pureGrey <> intoRope k <> " = " diff --git a/lib/Core/Telemetry/General.hs b/lib/Core/Telemetry/General.hs --- a/lib/Core/Telemetry/General.hs +++ b/lib/Core/Telemetry/General.hs @@ -5,9 +5,9 @@ /unimplemented/ -} -module Core.Telemetry.General ( - generalExporter, -) where +module Core.Telemetry.General + ( generalExporter + ) where import Core.Program.Context diff --git a/lib/Core/Telemetry/Honeycomb.hs b/lib/Core/Telemetry/Honeycomb.hs --- a/lib/Core/Telemetry/Honeycomb.hs +++ b/lib/Core/Telemetry/Honeycomb.hs @@ -29,11 +29,31 @@ applications. In the future you may be able to look at "Core.Telemetry.General" if you instead want to forward to a generic OpenTelemetry provider. + += Gotchas + +Spans are sent to Honeycomb as they are closed. Hence, if you have a long +lived span, while its child spans are sent to Honeycomb and are displayed, the +parent span will be initially missing. + +![Example Sad Trace](honeycomb-sad-trace.png) + +This is of course jarring, because the parent is defined in the code /before/ +the section where the child is called. So when writing long lived services, it +is best to call 'Core.Telemetry.Observability.beginTrace' inside a function +that will iterate continuously. That way complete telemetry will be generated +for that part of the code, making on-the-fly diagnosis and monitoring +possible. + +Either way, when the parent span is closed, unless the process is killed, the +full trace will be visible. + +![Example Happy Trace](honeycomb-happy-trace.png) -} -module Core.Telemetry.Honeycomb ( - Dataset, - honeycombExporter, -) where +module Core.Telemetry.Honeycomb + ( Dataset + , honeycombExporter + ) where import Codec.Compression.GZip qualified as GZip (compress) import Control.Exception.Safe qualified as Safe (catch, finally, throw) @@ -113,7 +133,7 @@ "The name of the dataset within your Honeycomb account that this program's telemetry will be written to." ) config1 - in config2 + in config2 setupHoneycombAction :: Context τ -> IO Forwarder setupHoneycombAction context = do @@ -211,7 +231,7 @@ , (JsonKey "data", JsonObject meta6) ] ) - in point + in point acquireConnection :: IORef (Maybe Connection) -> IO Connection acquireConnection r = do diff --git a/lib/Core/Telemetry/Identifiers.hs b/lib/Core/Telemetry/Identifiers.hs --- a/lib/Core/Telemetry/Identifiers.hs +++ b/lib/Core/Telemetry/Identifiers.hs @@ -15,24 +15,24 @@ identifiers into @traceparent@ headers. The key requirements are that traces be globally unique and that spans be unique within a trace. -} -module Core.Telemetry.Identifiers ( - -- * Traces and Spans - getIdentifierTrace, - getIdentifierSpan, - setIdentifierSpan, +module Core.Telemetry.Identifiers + ( -- * Traces and Spans + getIdentifierTrace + , getIdentifierSpan + , setIdentifierSpan - -- * Internals - createIdentifierTrace, - createIdentifierSpan, - hostMachineIdentity, - createTraceParentHeader, - parseTraceParentHeader, + -- * Internals + , createIdentifierTrace + , createIdentifierSpan + , hostMachineIdentity + , createTraceParentHeader + , parseTraceParentHeader -- for testing - toHexNormal64, - toHexReversed64, - toHexNormal32, - toHexReversed32, -) where + , toHexNormal64 + , toHexReversed64 + , toHexNormal32 + , toHexReversed32 + ) where import Control.Concurrent.MVar (modifyMVar_, readMVar) import Core.Data.Clock @@ -63,7 +63,7 @@ go [] = bogusAddress go (interface : remainder) = let address = mac interface - in if address /= loopbackAddress + in if address /= loopbackAddress then address else go remainder @@ -88,68 +88,68 @@ let p1 = packRope (toHexReversed64 (fromIntegral (unTime time))) p2 = packRope (toHexNormal16 rand) p3 = packRope (convertMACToHex address) - in Trace + in Trace (p1 <> p2 <> p3) convertMACToHex :: MAC -> [Char] convertMACToHex (MAC b1 b2 b3 b4 b5 b6) = - nibbleToHex b1 4 : - nibbleToHex b1 0 : - nibbleToHex b2 4 : - nibbleToHex b2 0 : - nibbleToHex b3 4 : - nibbleToHex b3 0 : - nibbleToHex b4 4 : - nibbleToHex b4 0 : - nibbleToHex b5 4 : - nibbleToHex b5 0 : - nibbleToHex b6 4 : - nibbleToHex b6 0 : - [] + nibbleToHex b1 4 + : nibbleToHex b1 0 + : nibbleToHex b2 4 + : nibbleToHex b2 0 + : nibbleToHex b3 4 + : nibbleToHex b3 0 + : nibbleToHex b4 4 + : nibbleToHex b4 0 + : nibbleToHex b5 4 + : nibbleToHex b5 0 + : nibbleToHex b6 4 + : nibbleToHex b6 0 + : [] where nibbleToHex w = unsafeToDigit . fromIntegral . (.&.) 0x0f . shiftR w toHexReversed64 :: Word64 -> [Char] toHexReversed64 w = - nibbleToHex 00 : - nibbleToHex 04 : - nibbleToHex 08 : - nibbleToHex 12 : - nibbleToHex 16 : - nibbleToHex 20 : - nibbleToHex 24 : - nibbleToHex 28 : -- Word32 - nibbleToHex 32 : - nibbleToHex 36 : - nibbleToHex 40 : - nibbleToHex 44 : - nibbleToHex 48 : - nibbleToHex 52 : - nibbleToHex 56 : - nibbleToHex 60 : - [] + nibbleToHex 00 + : nibbleToHex 04 + : nibbleToHex 08 + : nibbleToHex 12 + : nibbleToHex 16 + : nibbleToHex 20 + : nibbleToHex 24 + : nibbleToHex 28 + : nibbleToHex 32 -- Word32 + : nibbleToHex 36 + : nibbleToHex 40 + : nibbleToHex 44 + : nibbleToHex 48 + : nibbleToHex 52 + : nibbleToHex 56 + : nibbleToHex 60 + : [] where nibbleToHex = unsafeToDigit . fromIntegral . (.&.) 0x0f . shiftR w toHexNormal64 :: Word64 -> [Char] toHexNormal64 w = - nibbleToHex 60 : - nibbleToHex 56 : - nibbleToHex 52 : - nibbleToHex 48 : - nibbleToHex 44 : - nibbleToHex 40 : - nibbleToHex 36 : - nibbleToHex 32 : - nibbleToHex 28 : -- Word32 - nibbleToHex 24 : - nibbleToHex 20 : - nibbleToHex 16 : - nibbleToHex 12 : - nibbleToHex 08 : - nibbleToHex 04 : - nibbleToHex 00 : - [] + nibbleToHex 60 + : nibbleToHex 56 + : nibbleToHex 52 + : nibbleToHex 48 + : nibbleToHex 44 + : nibbleToHex 40 + : nibbleToHex 36 + : nibbleToHex 32 + : nibbleToHex 28 + : nibbleToHex 24 -- Word32 + : nibbleToHex 20 + : nibbleToHex 16 + : nibbleToHex 12 + : nibbleToHex 08 + : nibbleToHex 04 + : nibbleToHex 00 + : [] where nibbleToHex = unsafeToDigit . fromIntegral . (.&.) 0x0f . shiftR w @@ -159,39 +159,39 @@ -- toHexReversed32 :: Word32 -> [Char] toHexReversed32 w = - nibbleToHex 00 : - nibbleToHex 04 : - nibbleToHex 08 : - nibbleToHex 12 : - nibbleToHex 16 : - nibbleToHex 20 : - nibbleToHex 24 : - nibbleToHex 28 : - [] + nibbleToHex 00 + : nibbleToHex 04 + : nibbleToHex 08 + : nibbleToHex 12 + : nibbleToHex 16 + : nibbleToHex 20 + : nibbleToHex 24 + : nibbleToHex 28 + : [] where nibbleToHex = unsafeToDigit . fromIntegral . (.&.) 0x0f . shiftR w toHexNormal32 :: Word32 -> [Char] toHexNormal32 w = - nibbleToHex 28 : - nibbleToHex 24 : - nibbleToHex 20 : - nibbleToHex 16 : - nibbleToHex 12 : - nibbleToHex 08 : - nibbleToHex 04 : - nibbleToHex 00 : - [] + nibbleToHex 28 + : nibbleToHex 24 + : nibbleToHex 20 + : nibbleToHex 16 + : nibbleToHex 12 + : nibbleToHex 08 + : nibbleToHex 04 + : nibbleToHex 00 + : [] where nibbleToHex = unsafeToDigit . fromIntegral . (.&.) 0x0f . shiftR w toHexNormal16 :: Word16 -> [Char] toHexNormal16 w = - nibbleToHex 12 : - nibbleToHex 08 : - nibbleToHex 04 : - nibbleToHex 00 : - [] + nibbleToHex 12 + : nibbleToHex 08 + : nibbleToHex 04 + : nibbleToHex 00 + : [] where nibbleToHex = unsafeToDigit . fromIntegral . (.&.) 0x0f . shiftR w @@ -222,7 +222,7 @@ let t = fromIntegral (unTime time) :: Word64 r = fromIntegral rand :: Word64 w = (t .&. 0x0000ffffffffffff) .|. (shiftL r 48) - in Span + in Span ( packRope ( toHexReversed64 w ) @@ -244,7 +244,7 @@ createTraceParentHeader trace unique = let version = "00" flags = "00" - in version <> "-" <> unTrace trace <> "-" <> unSpan unique <> "-" <> flags + in version <> "-" <> unTrace trace <> "-" <> unSpan unique <> "-" <> flags {- | Parse a @traceparent@ header into a 'Trace' and 'Span', assuming it was a @@ -258,7 +258,7 @@ parseTraceParentHeader :: Rope -> Maybe (Trace, Span) parseTraceParentHeader header = let pieces = breakPieces (== '-') header - in case pieces of + in case pieces of ("00" : trace : unique : _ : []) -> Just (Trace trace, Span unique) _ -> Nothing @@ -317,4 +317,4 @@ let v = currentDatumFrom context modifyMVar_ v - (\datum -> pure datum{spanIdentifierFrom = Just unique}) + (\datum -> pure datum {spanIdentifierFrom = Just unique}) diff --git a/lib/Core/Telemetry/Observability.hs b/lib/Core/Telemetry/Observability.hs --- a/lib/Core/Telemetry/Observability.hs +++ b/lib/Core/Telemetry/Observability.hs @@ -135,35 +135,35 @@ will be gathered up and sent via the chosen exporter and forwarded to the observability or monitoring service you have chosen. -} -module Core.Telemetry.Observability ( - -- * Initializing - Exporter, - initializeTelemetry, +module Core.Telemetry.Observability + ( -- * Initializing + Exporter + , initializeTelemetry - -- * Traces - Trace (..), - Span (..), - beginTrace, - usingTrace, - usingTrace', - setServiceName, + -- * Traces + , Trace (..) + , Span (..) + , beginTrace + , usingTrace + , usingTrace' + , setServiceName - -- * Spans - Label, - encloseSpan, - setStartTime, - setSpanName, + -- * Spans + , Label + , encloseSpan + , setStartTime + , setSpanName - -- * Creating telemetry - MetricValue, - Telemetry (metric), - telemetry, + -- * Creating telemetry + , MetricValue + , Telemetry (metric) + , telemetry - -- * Events - sendEvent, - clearMetrics, - clearTrace, -) where + -- * Events + , sendEvent + , clearMetrics + , clearTrace + ) where import Control.Concurrent.MVar (modifyMVar_, newMVar, readMVar) import Control.Concurrent.STM (atomically) @@ -396,7 +396,7 @@ config0 config2 = List.foldl' f config1 exporters2 - in pure + in pure ( context { initialConfigFrom = config2 , initialExportersFrom = exporters2 @@ -410,7 +410,7 @@ f :: Config -> Exporter -> Config f config exporter = let setup = setupConfigFrom exporter - in setup config + in setup config type Label = Rope @@ -757,7 +757,7 @@ let v = currentDatumFrom context modifyMVar_ v - (\datum -> pure datum{spanTimeFrom = time}) + (\datum -> pure datum {spanTimeFrom = time}) {- | Override the name of the current span. @@ -779,7 +779,7 @@ let v = currentDatumFrom context modifyMVar_ v - (\datum -> pure datum{spanNameFrom = label}) + (\datum -> pure datum {spanNameFrom = label}) {- | Reset the accumulated metadata metrics to the emtpy set. diff --git a/lib/Core/Telemetry/Structured.hs b/lib/Core/Telemetry/Structured.hs --- a/lib/Core/Telemetry/Structured.hs +++ b/lib/Core/Telemetry/Structured.hs @@ -68,9 +68,9 @@ } @ -} -module Core.Telemetry.Structured ( - structuredExporter, -) where +module Core.Telemetry.Structured + ( structuredExporter + ) where import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TQueue (TQueue, writeTQueue) @@ -139,7 +139,7 @@ time = intoRope (show (spanTimeFrom datum)) meta7 = insertKeyValue "timestamp" (JsonString time) meta6 - in JsonObject meta7 + in JsonObject meta7 processStructuredOutput :: TQueue (Maybe Rope) -> [Datum] -> IO () processStructuredOutput out datums = do