diff --git a/exe/eventlog-summary/Main.hs b/exe/eventlog-summary/Main.hs --- a/exe/eventlog-summary/Main.hs +++ b/exe/eventlog-summary/Main.hs @@ -3,6 +3,11 @@ module Main where import Control.Monad +import qualified Data.Text as T +import qualified Data.ByteString.Char8 as B8 +import OpenTelemetry.Common +import OpenTelemetry.EventlogStreaming_Internal +import System.Environment import Data.Char (isDigit) import Data.Function import qualified Data.HashTable.IO as H @@ -10,13 +15,8 @@ import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IntMap import Data.List (sortOn) -import qualified Data.Text as T import Data.Word import Graphics.Vega.VegaLite hiding (name) -import OpenTelemetry.Common -import OpenTelemetry.EventlogStreaming_Internal -import OpenTelemetry.Exporter -import System.Environment import Text.Printf type HashTable k v = H.BasicHashTable k v @@ -68,18 +68,17 @@ pure ExportSuccess ) (pure ()) - metric_exporter = - Exporter - ( \metrics -> do - forM_ metrics $ \(Gauge _ label value) -> - modifyIORef metricStats $ \s -> case splitCapability $ T.unpack label of - (_, "threads") -> s {max_threads = max value (max_threads s)} - (Just cap, "heap_alloc_bytes") -> s {total_alloc_bytes = IntMap.insert cap value (total_alloc_bytes s)} - (_, "heap_live_bytes") -> s {max_live_bytes = max value (max_live_bytes s)} - _ -> s - pure ExportSuccess - ) - (pure ()) + metric_exporter <- aggregated $ Exporter + ( \metrics -> do + forM_ metrics $ \(AggregatedMetric (CaptureInstrument _ name) (MetricDatapoint _ value)) -> + modifyIORef metricStats $ \s -> case splitCapability (B8.unpack name) of + (_, "threads") -> s { max_threads = max value (max_threads s) } + (Just cap, "heap_alloc_bytes") -> s { total_alloc_bytes = IntMap.insert cap value (total_alloc_bytes s) } + (_, "heap_live_bytes") -> s { max_live_bytes = max value (max_live_bytes s) } + _ -> s + pure ExportSuccess + ) + (pure ()) exportEventlog span_exporter metric_exporter path leaderboard <- sortOn (total_ns . snd) <$> H.toList opCounts printf "Count\tTot ms\tMin ms\tMax ms\tOperation\n" diff --git a/exe/eventlog-to-zipkin/Main.hs b/exe/eventlog-to-zipkin/Main.hs --- a/exe/eventlog-to-zipkin/Main.hs +++ b/exe/eventlog-to-zipkin/Main.hs @@ -4,7 +4,7 @@ import qualified Data.Text as T import OpenTelemetry.EventlogStreaming_Internal -import OpenTelemetry.Exporter +import OpenTelemetry.Common import OpenTelemetry.ZipkinExporter import System.Environment (getArgs) import System.FilePath diff --git a/opentelemetry-extra.cabal b/opentelemetry-extra.cabal --- a/opentelemetry-extra.cabal +++ b/opentelemetry-extra.cabal @@ -2,7 +2,7 @@ name: opentelemetry-extra description: The OpenTelemetry Haskell Client https://opentelemetry.io category: OpenTelemetry -version: 0.5.3 +version: 0.6.0 license-file: LICENSE license: Apache-2.0 author: Dmitry Ivanov @@ -63,7 +63,7 @@ http-client, http-client-tls, http-types, - opentelemetry >= 0.5.3, + opentelemetry >= 0.6.0, random >= 1.1, scientific, text-show, @@ -97,7 +97,7 @@ bytestring, ghc-events, hashable, - opentelemetry >= 0.5.3, + opentelemetry >= 0.6.0, opentelemetry-extra, splitmix, tasty, @@ -107,7 +107,8 @@ generic-arbitrary, text, text-show, - unordered-containers + unordered-containers, + quickcheck-instances executable eventlog-to-zipkin import: options @@ -121,7 +122,7 @@ filepath, http-client, http-client-tls, - opentelemetry >= 0.5.3, + opentelemetry >= 0.6.0, opentelemetry-extra, text, typed-process @@ -140,7 +141,7 @@ build-depends: base, gauge >= 0.2.4, - opentelemetry >= 0.5.3, + opentelemetry >= 0.6.0, executable eventlog-to-chrome import: options @@ -150,7 +151,7 @@ base, exceptions, clock, - opentelemetry >= 0.5.3, + opentelemetry >= 0.6.0, opentelemetry-extra, executable eventlog-to-tracy @@ -161,7 +162,7 @@ base, clock, directory, - opentelemetry >= 0.5.3, + opentelemetry >= 0.6.0, opentelemetry-extra, process, @@ -173,8 +174,8 @@ base, hashtables, containers, - opentelemetry >= 0.5.3, + opentelemetry >= 0.6.0, opentelemetry-extra, hvega, - text - + text, + bytestring diff --git a/src/OpenTelemetry/ChromeExporter.hs b/src/OpenTelemetry/ChromeExporter.hs --- a/src/OpenTelemetry/ChromeExporter.hs +++ b/src/OpenTelemetry/ChromeExporter.hs @@ -5,14 +5,14 @@ import Control.Monad import Data.Aeson import qualified Data.ByteString.Lazy as LBS +import qualified Data.Text.Encoding as TE import Data.Function import Data.HashMap.Strict as HM import Data.List (sortOn) import Data.Word import OpenTelemetry.Common -import OpenTelemetry.EventlogStreaming_Internal -import OpenTelemetry.Exporter import System.IO +import OpenTelemetry.EventlogStreaming_Internal newtype ChromeBeginSpan = ChromeBegin Span @@ -101,26 +101,21 @@ hPutStrLn f "\n]" hClose f ) - metric_exporter = - Exporter - ( \metrics -> do - mapM_ - ( \case - Gauge ts name value -> do - LBS.hPutStr f $ - encode $ - object - [ "ph" .= ("C" :: String), - "name" .= name, - "ts" .= (div ts 1000), - "args" .= object [name .= Number (fromIntegral value)] - ] - LBS.hPutStr f ",\n" - ) - metrics - pure ExportSuccess - ) - (pure ()) + metric_exporter <- aggregated $ Exporter + ( \metrics -> do + -- forM_ metrics $ \(AggregatedMetric (SomeInstrument (TE.decodeUtf8 . instrumentName -> name)) (MetricDatapoint ts value)) -> do + forM_ metrics $ \(AggregatedMetric (CaptureInstrument _ (TE.decodeUtf8 -> name)) (MetricDatapoint ts value)) -> do + LBS.hPutStr f $ encode $ + object + [ "ph" .= ("C" :: String), + "name" .= name, + "ts" .= (div ts 1000), + "args" .= object [name .= Number (fromIntegral value)] + ] + LBS.hPutStr f ",\n" + pure ExportSuccess + ) + (pure ()) pure (span_exporter, metric_exporter) data DoWeCollapseThreads = CollapseThreads | SplitThreads diff --git a/src/OpenTelemetry/Common.hs b/src/OpenTelemetry/Common.hs --- a/src/OpenTelemetry/Common.hs +++ b/src/OpenTelemetry/Common.hs @@ -1,4 +1,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedStrings #-} module OpenTelemetry.Common where @@ -10,9 +13,13 @@ import qualified Data.Text as T import Data.Word import GHC.Generics -import OpenTelemetry.Exporter import OpenTelemetry.SpanContext import System.Clock +import Data.IORef (readIORef, modifyIORef, newIORef) +import Control.Monad +import Data.List (sortOn) +import qualified Data.ByteString as BS +import GHC.Int (Int8) type Timestamp = Word64 @@ -68,10 +75,43 @@ } deriving (Show, Eq) -data Metric - = Gauge !Timestamp !T.Text !Int +-- | Reflects the constructors of 'OpenTelemetry.Metrics_Internal.Instrument' +data InstrumentType + = CounterType + | UpDownCounterType + | ValueRecorderType + | SumObserverType + | UpDownSumObserverType + | ValueObserverType + deriving (Show, Eq, Enum, Generic) +instance Hashable InstrumentType + +data CaptureInstrument = CaptureInstrument + { instrumentType :: !InstrumentType, + instrumentName :: !BS.ByteString + } + deriving (Show, Eq, Generic) +instance Hashable CaptureInstrument + +-- | Based on https://github.com/open-telemetry/opentelemetry-proto/blob/1a931b4b57c34e7fd8f7dddcaa9b7587840e9c08/opentelemetry/proto/metrics/v1/metrics.proto#L96-L107 +data Metric = Metric + { instrument :: !CaptureInstrument, + datapoints :: ![MetricDatapoint Int] + } deriving (Show, Eq) +data AggregatedMetric = AggregatedMetric + { instrument :: !CaptureInstrument, + datapoint :: !(MetricDatapoint Int) + } + deriving (Show, Eq) + +data MetricDatapoint a = MetricDatapoint + { timestamp :: !Timestamp, + value :: !a + } + deriving (Show, Eq, Functor) + spanTraceId :: Span -> TraceId spanTraceId Span {spanContext = SpanContext _ tid} = tid @@ -100,6 +140,63 @@ data OpenTelemetryConfig = OpenTelemetryConfig { otcSpanExporter :: Exporter Span } + +data ExportResult + = ExportSuccess + | ExportFailedRetryable + | ExportFailedNotRetryable + deriving (Show, Eq) + +data Exporter thing + = Exporter + { export :: [thing] -> IO ExportResult, + shutdown :: IO () + } + +readInstrumentTag :: Int8 -> Maybe InstrumentType +readInstrumentTag 1 = Just CounterType +readInstrumentTag 2 = Just UpDownCounterType +readInstrumentTag 3 = Just ValueRecorderType +readInstrumentTag 4 = Just SumObserverType +readInstrumentTag 5 = Just UpDownSumObserverType +readInstrumentTag 6 = Just ValueObserverType +readInstrumentTag _ = Nothing + +additive :: InstrumentType -> Bool +additive CounterType = True +additive UpDownCounterType = True +additive ValueRecorderType = False +additive SumObserverType = True +additive UpDownSumObserverType = True +additive ValueObserverType = False + +noopExporter :: Exporter whatever +noopExporter = Exporter (const (pure ExportFailedNotRetryable)) (pure ()) + +aggregated :: Exporter AggregatedMetric -> IO (Exporter Metric) +aggregated (Exporter export shutdown) = do + -- We keep a mutable map of latest metric values. When a new datapoint comes + -- in, it either replaces or gets added to the current value, based on whether + -- the instrument is additive. + currentValuesRef <- newIORef HM.empty + return $ Exporter + { export = \metrics -> do + forM_ metrics $ \(Metric instrument datapoints) -> do + forM_ (sortOn timestamp datapoints) $ \dp@(MetricDatapoint ts value) -> + modifyIORef currentValuesRef $ + if additive (instrumentType instrument) + then HM.alter + (\case + Nothing -> Just dp + Just (MetricDatapoint _ oldValue) -> Just (MetricDatapoint ts $ oldValue+value)) + instrument + else HM.insert instrument dp + + -- Read the latest value for each instrument + currentValues <- readIORef currentValuesRef + export [AggregatedMetric i (currentValues HM.! i) | Metric i _ <- metrics] + , shutdown + } now64 :: IO Timestamp now64 = do diff --git a/src/OpenTelemetry/EventlogStreaming_Internal.hs b/src/OpenTelemetry/EventlogStreaming_Internal.hs --- a/src/OpenTelemetry/EventlogStreaming_Internal.hs +++ b/src/OpenTelemetry/EventlogStreaming_Internal.hs @@ -6,7 +6,9 @@ import Control.Concurrent (threadDelay) import qualified Data.Binary.Get as DBG import Data.Bits +import Data.Int import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy as LBS import qualified Data.HashMap.Strict as HM import qualified Data.IntMap as IM @@ -21,13 +23,14 @@ import GHC.Stack import OpenTelemetry.Common hiding (Event, Timestamp) import OpenTelemetry.Debug -import OpenTelemetry.Eventlog_Internal -import OpenTelemetry.Exporter import OpenTelemetry.SpanContext +import OpenTelemetry.Eventlog (InstrumentId, InstrumentName) +import Text.Printf +import qualified System.Random.SplitMix as R + +import OpenTelemetry.Eventlog_Internal import System.Clock import System.IO -import qualified System.Random.SplitMix as R -import Text.Printf data WatDoOnEOF = StopOnEOF | SleepAndRetryOnEOF @@ -35,6 +38,7 @@ { originTimestamp :: !Timestamp, threadMap :: IM.IntMap ThreadId, spans :: HM.HashMap SpanId Span, + instrumentMap :: HM.HashMap InstrumentId CaptureInstrument, traceMap :: HM.HashMap ThreadId TraceId, serial2sid :: HM.HashMap Word64 SpanId, thread2sid :: HM.HashMap ThreadId SpanId, @@ -43,13 +47,12 @@ counterEventsProcessed :: !Int, counterOpenTelemetryEventsProcessed :: !Int, counterSpansEmitted :: !Int, - threadCount :: !Int, randomGen :: R.SMGen } deriving (Show) initialState :: Word64 -> R.SMGen -> State -initialState timestamp = S timestamp mempty mempty mempty mempty mempty 0 0 0 0 0 0 +initialState timestamp = S timestamp mempty mempty mempty mempty mempty mempty 0 0 0 0 0 data EventSource = EventLogHandle Handle WatDoOnEOF @@ -150,30 +153,24 @@ let trace_id = case m_trace_id of Just t -> t Nothing -> TId originTimestamp -- TODO: something more random - in ( st - { traceMap = HM.insert new_tid trace_id traceMap, - threadCount = threadCount + 1 - }, - [], - [Gauge now "threads" (threadCount + 1)] - ) + in (st { traceMap = HM.insert new_tid trace_id traceMap } + , [] + , [Metric threadsI [MetricDatapoint now 1]]) (RunThread tid, Just cap, _) -> (st {threadMap = IM.insert cap tid threadMap}, [], []) (StopThread tid tstatus, Just cap, _) | isTerminalThreadStatus tstatus -> ( st - { threadMap = IM.delete cap threadMap, - traceMap = HM.delete tid traceMap, - threadCount = threadCount - 1 + { threadMap = IM.delete cap threadMap + , traceMap = HM.delete tid traceMap }, - [], - [Gauge now "threads" (threadCount - 1)] - ) + [] + , [Metric threadsI [MetricDatapoint now (-1)]]) (StartGC, _, _) -> (st {gcStartedAt = now}, [], []) - (HeapLive {liveBytes}, _, _) -> (st, [], [Gauge now "heap_live_bytes" $ fromIntegral liveBytes]) + (HeapLive {liveBytes}, _, _) -> (st, [], [Metric heapLiveBytesI [MetricDatapoint now $ fromIntegral liveBytes]]) (HeapAllocated {allocBytes}, (Just cap), _) -> - (st, [], [Gauge now ("cap_" <> T.pack (show cap) <> "_heap_alloc_bytes") $ fromIntegral allocBytes]) + (st, [], [Metric (heapAllocBytesI cap) [MetricDatapoint now $ fromIntegral allocBytes]]) (EndGC, _, _) -> let (span_id, randomGen') = R.nextWord64 randomGen sp = @@ -191,11 +188,24 @@ } spans' = fmap (\live_span -> live_span {spanNanosecondsSpentInGC = (now - gcStartedAt) + spanNanosecondsSpentInGC live_span}) spans st' = st {randomGen = randomGen', spans = spans'} - in (st', [sp], [Gauge now "gc" (fromIntegral $ now - gcStartedAt)]) + in (st', [sp], [Metric gcTimeI [MetricDatapoint now (fromIntegral $ now - gcStartedAt)]]) (parseOpenTelemetry -> Just ev', _, fromMaybe 1 -> tid) -> handleOpenTelemetryEventlogEvent ev' st (tid, now, m_trace_id) _ -> (st, [], []) + where + threadsI :: CaptureInstrument + threadsI = CaptureInstrument UpDownSumObserverType "threads" + heapLiveBytesI :: CaptureInstrument + heapLiveBytesI = CaptureInstrument ValueObserverType "heap_live_bytes" + + gcTimeI :: CaptureInstrument + gcTimeI = CaptureInstrument SumObserverType "gc" + + heapAllocBytesI :: Int -> CaptureInstrument + heapAllocBytesI cap = CaptureInstrument SumObserverType ("cap_" <> B8.pack (show cap) <> "_heap_alloc_bytes") + + isTerminalThreadStatus :: ThreadStopStatus -> Bool isTerminalThreadStatus ThreadFinished = True isTerminalThreadStatus _ = False @@ -208,6 +218,8 @@ | SetParentEv SpanInFlight SpanContext | SetTraceEv SpanInFlight TraceId | SetSpanEv SpanInFlight SpanId + | DeclareInstrumentEv InstrumentType InstrumentId InstrumentName + | MetricCaptureEv InstrumentId Int deriving (Show, Eq, Generic) handleOpenTelemetryEventlogEvent :: @@ -293,6 +305,11 @@ Just span_id -> let (st', sp) = emitSpan serial span_id st in (st', [sp {spanOperation = operation, spanStartedAt = now, spanThreadId = tid}], []) + DeclareInstrumentEv iType iId iName -> + (st { instrumentMap = HM.insert iId (CaptureInstrument iType iName) (instrumentMap st) }, [], []) + MetricCaptureEv instrumentId val -> case HM.lookup instrumentId (instrumentMap st) of + Just instrument -> (st, [], [Metric instrument [MetricDatapoint now val]]) + Nothing -> error $ "Undeclared instrument id: " ++ show instrumentId createSpan :: SpanId -> Span -> State -> State createSpan span_id sp st = @@ -362,38 +379,42 @@ parseText :: [T.Text] -> Maybe OpenTelemetryEventlogEvent parseText = - \case - ("ot2" : "begin" : "span" : serial_text : name) -> - let serial = read (T.unpack serial_text) - operation = T.intercalate " " name - in Just $ BeginSpanEv (SpanInFlight serial) (SpanName operation) - ["ot2", "end", "span", serial_text] -> - let serial = read (T.unpack serial_text) - in Just $ EndSpanEv (SpanInFlight serial) - ("ot2" : "set" : "tag" : serial_text : k : v) -> - let serial = read (T.unpack serial_text) - in Just $ TagEv (SpanInFlight serial) (TagName k) (TagVal $ T.unwords v) - ["ot2", "set", "traceid", serial_text, trace_id_text] -> - let serial = read (T.unpack serial_text) - trace_id = TId (read ("0x" <> T.unpack trace_id_text)) - in Just $ SetTraceEv (SpanInFlight serial) trace_id - ["ot2", "set", "spanid", serial_text, new_span_id_text] -> - let serial = read (T.unpack serial_text) - span_id = (SId (read ("0x" <> T.unpack new_span_id_text))) - in Just $ SetSpanEv (SpanInFlight serial) span_id - ["ot2", "set", "parent", serial_text, trace_id_text, parent_span_id_text] -> - let trace_id = TId (read ("0x" <> T.unpack trace_id_text)) - serial = read (T.unpack serial_text) - psid = SId (read ("0x" <> T.unpack parent_span_id_text)) - in Just $ - SetParentEv - (SpanInFlight serial) - (SpanContext psid trace_id) - ("ot2" : "add" : "event" : serial_text : k : v) -> - let serial = read (T.unpack serial_text) - in Just . EventEv (SpanInFlight serial) (EventName k) $ EventVal $ T.unwords v - ("ot2" : rest) -> error $ printf "Unrecognized %s" (show rest) - _ -> Nothing + \case + ("ot2" : "begin" : "span" : serial_text : name) -> + let serial = read (T.unpack serial_text) + operation = T.intercalate " " name + in Just $ BeginSpanEv (SpanInFlight serial) (SpanName operation) + ["ot2", "end", "span", serial_text] -> + let serial = read (T.unpack serial_text) + in Just $ EndSpanEv (SpanInFlight serial) + ("ot2" : "set" : "tag" : serial_text : k : v) -> + let serial = read (T.unpack serial_text) + in Just $ TagEv (SpanInFlight serial) (TagName k) (TagVal $ T.unwords v) + ["ot2", "set", "traceid", serial_text, trace_id_text] -> + let serial = read (T.unpack serial_text) + trace_id = TId (read ("0x" <> T.unpack trace_id_text)) + in Just $ SetTraceEv (SpanInFlight serial) trace_id + ["ot2", "set", "spanid", serial_text, new_span_id_text] -> + let serial = read (T.unpack serial_text) + span_id = (SId (read ("0x" <> T.unpack new_span_id_text))) + in Just $ SetSpanEv (SpanInFlight serial) span_id + ["ot2", "set", "parent", serial_text, trace_id_text, parent_span_id_text] -> + let trace_id = TId (read ("0x" <> T.unpack trace_id_text)) + serial = read (T.unpack serial_text) + psid = SId (read ("0x" <> T.unpack parent_span_id_text)) + in Just $ + SetParentEv + (SpanInFlight serial) + (SpanContext psid trace_id) + ("ot2" : "add" : "event" : serial_text : k : v) -> + let serial = read (T.unpack serial_text) + in Just . EventEv (SpanInFlight serial) (EventName k) $ EventVal $ T.unwords v + ("ot2" : "metric" : "capture" : instrumentIdText : valStr) -> + let instrumentId = read ("0x" ++ T.unpack instrumentIdText) + val = read (T.unpack $ T.intercalate " " valStr) + in Just $ MetricCaptureEv instrumentId val + ("ot2" : rest) -> error $ printf "Unrecognized %s" (show rest) + _ -> Nothing headerP :: DBG.Get (Maybe MsgType) headerP = do @@ -442,6 +463,13 @@ SET_SPAN_ID -> SetSpanEv <$> (SpanInFlight <$> DBG.getWord64le) <*> (SId <$> DBG.getWord64le) + DECLARE_INSTRUMENT -> DeclareInstrumentEv + <$> (instrumentTagP =<< DBG.getInt8) + <*> DBG.getWord64le + <*> (LBS.toStrict <$> DBG.getRemainingLazyByteString) + METRIC_CAPTURE -> MetricCaptureEv + <$> DBG.getWord64le + <*> (fromIntegral <$> DBG.getInt64le) MsgType mti -> fail $ "Log event of type " ++ show mti ++ " is not supported" @@ -450,6 +478,15 @@ DBG.lookAheadM headerP >>= \case Nothing -> return Nothing Just msgType -> logEventBodyP msgType >>= return . Just + +instrumentTagP :: MonadFail m => Int8 -> m InstrumentType +instrumentTagP 1 = return CounterType +instrumentTagP 2 = return UpDownCounterType +instrumentTagP 3 = return ValueRecorderType +instrumentTagP 4 = return SumObserverType +instrumentTagP 5 = return UpDownSumObserverType +instrumentTagP 6 = return ValueObserverType +instrumentTagP n = fail $ "Bad instrument tag: " ++ show n parseByteString :: B.ByteString -> Maybe OpenTelemetryEventlogEvent parseByteString = DBG.runGet logEventP . LBS.fromStrict diff --git a/src/OpenTelemetry/ZipkinExporter.hs b/src/OpenTelemetry/ZipkinExporter.hs --- a/src/OpenTelemetry/ZipkinExporter.hs +++ b/src/OpenTelemetry/ZipkinExporter.hs @@ -17,7 +17,6 @@ import Network.HTTP.Types import OpenTelemetry.Common import OpenTelemetry.Debug -import OpenTelemetry.Exporter import OpenTelemetry.SpanContext import System.IO.Unsafe import Text.Printf diff --git a/unit-tests/Arbitrary.hs b/unit-tests/Arbitrary.hs --- a/unit-tests/Arbitrary.hs +++ b/unit-tests/Arbitrary.hs @@ -10,10 +10,12 @@ import qualified Data.Text as T import OpenTelemetry.Common import OpenTelemetry.Eventlog +import OpenTelemetry.Metrics_Internal import OpenTelemetry.EventlogStreaming_Internal import OpenTelemetry.SpanContext import Test.QuickCheck import Test.QuickCheck.Arbitrary.Generic +import Test.QuickCheck.Instances.ByteString() import TextShow newtype TextWithout0 = TextWithout0 T.Text @@ -44,7 +46,21 @@ deriving instance Arbitrary TraceId +instance Arbitrary SomeInstrument where + arbitrary = oneof + [ SomeInstrument <$> (Counter <$> arbitrary <*> arbitrary) + , SomeInstrument <$> (UpDownCounter <$> arbitrary <*> arbitrary) + , SomeInstrument <$> (ValueRecorder <$> arbitrary <*> arbitrary) + , SomeInstrument <$> (SumObserver <$> arbitrary <*> arbitrary) + , SomeInstrument <$> (UpDownSumObserver <$> arbitrary <*> arbitrary) + , SomeInstrument <$> (ValueObserver <$> arbitrary <*> arbitrary) + ] + instance Arbitrary SpanContext where + arbitrary = genericArbitrary + shrink = genericShrink + +instance Arbitrary InstrumentType where arbitrary = genericArbitrary shrink = genericShrink diff --git a/unit-tests/LogEventSerializer.hs b/unit-tests/LogEventSerializer.hs --- a/unit-tests/LogEventSerializer.hs +++ b/unit-tests/LogEventSerializer.hs @@ -8,6 +8,7 @@ import OpenTelemetry.Common import OpenTelemetry.EventlogStreaming_Internal import qualified OpenTelemetry.Eventlog_Internal as BE +import OpenTelemetry.Metrics_Internal logEventToBs :: OpenTelemetryEventlogEvent -> BS.ByteString logEventToBs = LBS.toStrict . toLazyByteString . logEventToBuilder @@ -23,6 +24,17 @@ logEventToBuilder (SetParentEv locId spnCtx) = BE.builder_setParentSpanContext locId spnCtx logEventToBuilder (SetTraceEv localId traceId) = BE.builder_setTraceId localId traceId logEventToBuilder (SetSpanEv localId spanId') = BE.builder_setSpanId localId spanId' +logEventToBuilder (DeclareInstrumentEv tag iId iName) = case declareInstrumentEvToInstrument tag iId iName of + SomeInstrument i -> BE.builder_declareInstrument i +logEventToBuilder (MetricCaptureEv i val) = BE.builder_captureMetric i val logEventToUserBinaryMessage :: OpenTelemetryEventlogEvent -> EventInfo logEventToUserBinaryMessage = UserBinaryMessage . logEventToBs + +declareInstrumentEvToInstrument :: InstrumentType -> InstrumentId -> InstrumentName -> SomeInstrument +declareInstrumentEvToInstrument CounterType iid name = SomeInstrument $ Counter name iid +declareInstrumentEvToInstrument UpDownCounterType iid name = SomeInstrument $ UpDownCounter name iid +declareInstrumentEvToInstrument ValueRecorderType iid name = SomeInstrument $ ValueRecorder name iid +declareInstrumentEvToInstrument SumObserverType iid name = SomeInstrument $ SumObserver name iid +declareInstrumentEvToInstrument UpDownSumObserverType iid name = SomeInstrument $ UpDownSumObserver name iid +declareInstrumentEvToInstrument ValueObserverType iid name = SomeInstrument $ ValueObserver name iid