core-telemetry 0.1.8.1 → 0.1.9.1

raw patch · 4 files changed

+311/−64 lines, 4 filesdep +network-infodep −locatorsdep −uuidPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: network-info

Dependencies removed: locators, uuid

API changes (from Hackage documentation)

Files

• core-telemetry.cabal +3/−3
• lib/Core/Telemetry.hs +8/−1
• lib/Core/Telemetry/Identifiers.hs +274/−0
• lib/Core/Telemetry/Observability.hs +26/−60

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           core-telemetry-version:        0.1.8.1+version:        0.1.9.1 synopsis:       Advanced telemetry description:    This is part of a library to help build command-line programs, both tools and                 longer-running daemons.@@ -42,6 +42,7 @@       Core.Telemetry.Console       Core.Telemetry.General       Core.Telemetry.Honeycomb+      Core.Telemetry.Identifiers       Core.Telemetry.Observability       Core.Telemetry.Structured   hs-source-dirs:@@ -58,8 +59,8 @@     , exceptions     , http-streams     , io-streams-    , locators     , mtl+    , network-info     , random     , safe-exceptions     , scientific@@ -67,5 +68,4 @@     , template-haskell >=2.14 && <3     , text     , unix-    , uuid   default-language: Haskell2010

@@ -28,11 +28,18 @@     module Core.Telemetry.Console,     module Core.Telemetry.General,     module Core.Telemetry.Honeycomb,-    module Core.Telemetry.Structured+    module Core.Telemetry.Structured,++    -- * Internals++    -- |+    -- Various elper functions.+    module Core.Telemetry.Identifiers ) where  import Core.Telemetry.Console import Core.Telemetry.General import Core.Telemetry.Honeycomb+import Core.Telemetry.Identifiers import Core.Telemetry.Observability import Core.Telemetry.Structured

@@ -0,0 +1,274 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralisedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# OPTIONS_HADDOCK prune #-}++{- |+Machinery for generating identifiers to be used in traces and spans. Meets the+requirements of the [W3C Trace+Context](https://www.w3.org/TR/trace-context/#traceparent-header)+specification, specifically as relates to forming trace identifiers and span+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,++    -- * Internals+    createIdentifierTrace,+    createIdentifierSpan,+    hostMachineIdentity,+    createTraceParentHeader,+    -- for testing+    toHexNormal64,+    toHexReversed64,+    toHexNormal32,+    toHexReversed32,+) where++import Control.Concurrent.MVar (readMVar)+import Core.Program.Context+import Core.System (unsafePerformIO)+import Core.System.Base (liftIO)+import Core.System.External (TimeStamp (unTimeStamp))+import Core.Text.Rope+import Data.Bits (shiftL, shiftR, (.&.), (.|.))+import Data.Text.Internal.Unsafe.Char (unsafeChr8)+import GHC.Word+import Network.Info (MAC (..), NetworkInterface, getNetworkInterfaces, mac)++{- |+Get the MAC address of the first interface that's not the loopback device. If+something goes weird then we return a valid but bogus address (in the locally+administered addresses block).++@since 0.1.9+-}+hostMachineIdentity :: MAC+hostMachineIdentity = unsafePerformIO $ do+    interfaces <- getNetworkInterfaces+    pure (go interfaces)+  where+    go :: [NetworkInterface] -> MAC+    go [] = bogusAddress+    go (interface : remainder) =+        let address = mac interface+         in if address /= loopbackAddress+                then address+                else go remainder++    loopbackAddress = MAC 00 00 00 00 00 00+    bogusAddress = MAC 0xfe 0xff 0xff 0xff 0xff 0xff+{-# NOINLINE hostMachineIdentity #-}++{- |+Generate an identifier suitable for use in a trace context. Trace identifiers+are 16 bytes. We incorporate the time to nanosecond precision, the host+system's MAC address, and a random element. This is similar to a version 1+UUID, but we render the least significant bits of the time stamp ordered first+so that visual distinctiveness is on the left. The MAC address in the lower 48+bits is /not/ reversed, leaving the most distinctiveness [the actual host as+opposed to manufacturer OIN] hanging on the right hand edge of the identifier.+The two bytes of randomness are in the middle.++@since 0.1.9+-}+createIdentifierTrace :: TimeStamp -> Word16 -> MAC -> Trace+createIdentifierTrace time rand address =+    let p1 = packRope (toHexReversed64 (fromIntegral time))+        p2 = packRope (toHexNormal16 rand)+        p3 = packRope (convertMACToHex address)+     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 :+    []+  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 :+    []+  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 :+    []+  where+    nibbleToHex = unsafeToDigit . fromIntegral . (.&.) 0x0f . shiftR w++--+-- Convert a 32-bit word to eight characters, but reversed so the least+-- significant bits are first.+--+toHexReversed32 :: Word32 -> [Char]+toHexReversed32 w =+    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 :+    []+  where+    nibbleToHex = unsafeToDigit . fromIntegral . (.&.) 0x0f . shiftR w++toHexNormal16 :: Word16 -> [Char]+toHexNormal16 w =+    nibbleToHex 12 :+    nibbleToHex 08 :+    nibbleToHex 04 :+    nibbleToHex 00 :+    []+  where+    nibbleToHex = unsafeToDigit . fromIntegral . (.&.) 0x0f . shiftR w++{-+byteToHex :: Word8 -> [Char]+byteToHex c =+    let !low = unsafeToDigit (c .&. 0x0f)+        !hi = unsafeToDigit ((c .&. 0xf0) `shiftR` 4)+     in hi : low : []+-}++-- convert a nibble to its hexidecimal character equivalent+unsafeToDigit :: Word8 -> Char+unsafeToDigit w =+    if w < 10+        then unsafeChr8 (48 + w)+        else unsafeChr8 (97 + w - 10)++{- |+Generate an identifier for a span. We only have 8 bytes to work with. We use+the nanosecond prescision timestamp with the nibbles reversed, and then+overwrite the last two bytes with a random value.++@since 0.1.9+-}+createIdentifierSpan :: TimeStamp -> Word16 -> Span+createIdentifierSpan time rand =+    let t = fromIntegral (unTimeStamp time) :: Word64+        r = fromIntegral rand :: Word64+        w = (t .&. 0x0000ffffffffffff) .|. (shiftL r 48)+     in Span+            ( packRope+                ( toHexReversed64 w+                )+            )++{- |+Render the 'Trace' and 'Span' identifiers representing a span calling onward+to another component in a distributed system. The W3C Trace Context+recommendation specifies the HTTP header @traceparent@ with the 16 byte trace+identifier and the 8 byte span identifier formatted as follows:++@+traceparent: 00-fd533dbf96ecdc610156482ae36c24f7-1d1e9dbf96ec4649-00+@++@since 0.1.9+-}+createTraceParentHeader :: Trace -> Span -> Rope+createTraceParentHeader trace unique =+    let version = "00"+        flags = "00"+     in version <> "-" <> unTrace trace <> "-" <> unSpan unique <> "-" <> flags++{- |+Get the identifier of the current trace, if you are ithin a trace started by+'beginTrace' or 'usingTrace'.++@since 0.1.9+-}+getIdentifierTrace :: Program τ (Maybe Trace)+getIdentifierTrace = do+    context <- getContext++    liftIO $ do+        let v = currentDatumFrom context+        datum <- readMVar v++        pure (traceIdentifierFrom datum)++{- |+Get the identifier of the current span, if you are currently within a span+created by 'encloseSpan'.++@since 0.1.9+-}+getIdentifierSpan :: Program τ (Maybe Span)+getIdentifierSpan = do+    context <- getContext++    liftIO $ do+        let v = currentDatumFrom context+        datum <- readMVar v++        pure (spanIdentifierFrom datum)

@@ -1,8 +1,10 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralisedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RankNTypes #-}+{-# OPTIONS_HADDOCK prune #-}  {- | Traditional \"monitoring\" systems were concerned with gathering together obscene@@ -165,23 +167,21 @@ import Core.Encoding.Json import Core.Program.Arguments import Core.Program.Context-import Core.Program.Execute (sleepThread) import Core.Program.Logging import Core.System.Base (liftIO) import Core.System.External (TimeStamp (unTimeStamp), getCurrentTimeNanoseconds)+import Core.Telemetry.Identifiers import Core.Text.Rope import Core.Text.Utilities (oxford, quote) import qualified Data.ByteString as B (ByteString) import qualified Data.ByteString.Lazy as L (ByteString)-import Data.Int (Int32, Int64) import qualified Data.List as List (foldl')-import Data.Locator (padWithZeros, toBase62, toLatin25) import Data.Scientific (Scientific) import qualified Data.Text as T (Text) import qualified Data.Text.Lazy as U (Text)-import Data.UUID (UUID, toWords)-import Data.UUID.V1 (nextUUID)-import Data.Word (Word32, Word64)+import GHC.Int+import GHC.Word+import System.Random (randomIO)  {- | A telemetry value that can be sent over the wire. This is a wrapper around@@ -388,13 +388,19 @@ encloseSpan label action = do     context <- getContext -    unique <- generateIdentifierBase62+    start <- liftIO $ do+        getCurrentTimeNanoseconds++    rand <- liftIO $ do+        (randomIO :: IO Word16)++    let unique = createIdentifierSpan start rand+     internal label emptyRope-    internal "span = " unique+    internal "span = " (unSpan unique)      liftIO $ do         -- prepare new span-        start <- getCurrentTimeNanoseconds          -- slightly tricky: create a new Context with a new MVar with an         -- forked copy of the current Datum, creating the nested span.@@ -403,7 +409,7 @@          let datum' =                 datum-                    { spanIdentifierFrom = Just (Span unique)+                    { spanIdentifierFrom = Just unique                     , spanNameFrom = label                     , spanTimeFrom = start                     , parentIdentifierFrom = spanIdentifierFrom datum@@ -437,54 +443,7 @@         -- now back to your regularly scheduled Haskell program         pure result -getUniqueId :: Program τ UUID-getUniqueId = do-    next <- liftIO nextUUID-    case next of-        Just uuid -> pure uuid-        Nothing -> do-            sleepThread 0.000001-            getUniqueId- {- |-Generate a UUID but expressed in Latin 25, with least significant bits (the-time stamp) ordered to the left so that visual distinctiveness is on the left.-The MAC address in the lower 48 bits is /not/ reversed, leaving the most-distinctiveness [the actual host as opposed to manufacturer] hanging on the-right hand edge of the identifier.--}-generateIdentifierLatin25 :: Program τ Rope-generateIdentifierLatin25 = do-    uuid <- getUniqueId-    let (w1, w2, w3, w4) = toWords uuid-        l1 = convertL w1-        l2 = convertL w2-        l3 = convertB w3-        l4 = convertB w4-        result = l1 <> l2 <> l3 <> l4-    pure result-  where-    convertL = intoRope . padWithZeros 7 . reverse . toLatin25 . fromIntegral-    convertB = intoRope . padWithZeros 7 . toLatin25 . fromIntegral--{- |-Generate a UUID but expressed in Base 62.--}-generateIdentifierBase62 :: Program τ Rope-generateIdentifierBase62 = do-    uuid <- getUniqueId-    let (w1, w2, w3, w4) = toWords uuid-        b1 = convertL w1-        b2 = convertL w2-        b3 = convertB w3-        b4 = convertB w4-        result = b1 <> b2 <> b3 <> b4-    pure result-  where-    convertL = intoRope . padWithZeros 6 . reverse . toBase62 . fromIntegral-    convertB = intoRope . padWithZeros 6 . toBase62 . fromIntegral--{- | Start a new trace. A random identifier will be generated.  You /must/ have a single \"root span\" immediately below starting a new trace.@@ -499,9 +458,16 @@ -} beginTrace :: Program τ α -> Program τ α beginTrace action = do-    trace <- generateIdentifierLatin25-    usingTrace (Trace trace) Nothing action+    now <- liftIO $ do+        getCurrentTimeNanoseconds +    rand <- liftIO $ do+        (randomIO :: IO Word16)++    let trace = createIdentifierTrace now rand hostMachineIdentity++    usingTrace trace Nothing action+ {- | Begin a new trace, but using a trace identifier provided externally. This is the most common case. Internal services that are play a part of a larger@@ -547,7 +513,7 @@         let datum2 =                 datum                     { traceIdentifierFrom = Just trace-                    , parentIdentifierFrom = possibleParent+                    , spanIdentifierFrom = possibleParent                     }          -- fork the Context