diff --git a/opentelemetry.cabal b/opentelemetry.cabal --- a/opentelemetry.cabal +++ b/opentelemetry.cabal @@ -2,7 +2,7 @@ name: opentelemetry 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 @@ -56,8 +56,7 @@ hs-source-dirs: src exposed-modules: OpenTelemetry.SpanContext - OpenTelemetry.Exporter OpenTelemetry.Propagation OpenTelemetry.Eventlog OpenTelemetry.Eventlog_Internal - + OpenTelemetry.Metrics_Internal diff --git a/src/OpenTelemetry/Eventlog.hs b/src/OpenTelemetry/Eventlog.hs --- a/src/OpenTelemetry/Eventlog.hs +++ b/src/OpenTelemetry/Eventlog.hs @@ -1,9 +1,11 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE PatternSynonyms #-} module OpenTelemetry.Eventlog - ( beginSpan, + ( -- * Spans + beginSpan, endSpan, withSpan, withSpan_, @@ -13,8 +15,32 @@ addEvent, setParentSpanContext, SpanInFlight (..), - ) -where + -- * Metrics + mkCounter, + mkUpDownCounter, + mkValueRecorder, + mkSumObserver, + mkUpDownSumObserver, + mkValueObserver, + add, + record, + observe, + MI.Instrument, + MI.SomeInstrument(..), + MI.Counter, + MI.UpDownCounter, + MI.ValueRecorder, + MI.SumObserver, + MI.UpDownSumObserver, + MI.ValueObserver, + MI.Synchronicity(..), + MI.Additivity(..), + MI.Monotonicity(..), + MI.InstrumentName, + MI.InstrumentId, + MI.instrumentName, + MI.instrumentId + ) where import Control.Monad.Catch import Control.Monad.IO.Class @@ -23,6 +49,7 @@ import OpenTelemetry.Eventlog_Internal (SpanInFlight (..)) import qualified OpenTelemetry.Eventlog_Internal as I import OpenTelemetry.SpanContext +import qualified OpenTelemetry.Metrics_Internal as MI {-# INLINE withSpan #-} withSpan :: @@ -82,3 +109,60 @@ {-# INLINE setParentSpanContext #-} setParentSpanContext :: MonadIO m => SpanInFlight -> SpanContext -> m () setParentSpanContext sp ctx = I.traceBuilder $ I.builder_setParentSpanContext sp ctx + +{-# INLINE mkCounter #-} +mkCounter :: MonadIO m => MI.InstrumentName -> m MI.Counter +mkCounter name = do + inst <- MI.Counter name <$> I.nextInstrumentId + I.traceBuilder $ I.builder_declareInstrument inst + return inst + +{-# INLINE mkUpDownCounter #-} +mkUpDownCounter :: MonadIO m => MI.InstrumentName -> m MI.UpDownCounter +mkUpDownCounter name = do + inst <- MI.UpDownCounter name <$> I.nextInstrumentId + I.traceBuilder $ I.builder_declareInstrument inst + return inst + +{-# INLINE mkValueRecorder #-} +mkValueRecorder :: MonadIO m => MI.InstrumentName -> m MI.ValueRecorder +mkValueRecorder name = do + inst <- MI.ValueRecorder name <$> I.nextInstrumentId + I.traceBuilder $ I.builder_declareInstrument inst + return inst + +{-# INLINE mkSumObserver #-} +mkSumObserver :: MonadIO m => MI.InstrumentName -> m MI.SumObserver +mkSumObserver name = do + inst <- MI.SumObserver name <$> I.nextInstrumentId + I.traceBuilder $ I.builder_declareInstrument inst + return inst + +{-# INLINE mkUpDownSumObserver #-} +mkUpDownSumObserver :: MonadIO m => MI.InstrumentName -> m MI.UpDownSumObserver +mkUpDownSumObserver name = do + inst <- MI.UpDownSumObserver name <$> I.nextInstrumentId + I.traceBuilder $ I.builder_declareInstrument inst + return inst + +{-# INLINE mkValueObserver #-} +mkValueObserver :: MonadIO m => MI.InstrumentName -> m MI.ValueObserver +mkValueObserver name = do + inst <- MI.ValueObserver name <$> I.nextInstrumentId + I.traceBuilder $ I.builder_declareInstrument inst + return inst + +-- | Take a measurement for a synchronous, additive instrument ('Counter', 'UpDownCounter') +{-# INLINE add #-} +add :: MonadIO m => MI.Instrument 'MI.Synchronous 'MI.Additive m' -> Int -> m () +add i v = I.traceBuilder $ I.builder_captureMetric (MI.instrumentId i) v + +-- | Take a measurement for a synchronous, non-additive instrument ('ValueRecorder') +{-# INLINE record #-} +record :: MonadIO m => MI.Instrument 'MI.Synchronous 'MI.NonAdditive m' -> Int -> m () +record i v = I.traceBuilder $ I.builder_captureMetric (MI.instrumentId i) v + +-- | Take a measurement for an asynchronous instrument ('SumObserver', 'UpDownSumObserver', 'ValueObserver') +{-# INLINE observe #-} +observe :: MonadIO m => MI.Instrument 'MI.Asynchronous a m' -> Int -> m () +observe i v = I.traceBuilder $ I.builder_captureMetric (MI.instrumentId i) v diff --git a/src/OpenTelemetry/Eventlog_Internal.hs b/src/OpenTelemetry/Eventlog_Internal.hs --- a/src/OpenTelemetry/Eventlog_Internal.hs +++ b/src/OpenTelemetry/Eventlog_Internal.hs @@ -1,6 +1,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE GADTs #-} module OpenTelemetry.Eventlog_Internal where @@ -15,7 +16,9 @@ import Data.Word (Word64, Word8) import Debug.Trace.Binary import OpenTelemetry.SpanContext +import OpenTelemetry.Metrics_Internal import Prelude hiding (span) +import Data.Int -- This is not a Span Id in terms of OpenTelemetry. -- It's unique only in scope of one process, not globally. @@ -27,7 +30,7 @@ newtype MsgType = MsgType Word8 deriving (Show) -pattern BEGIN_SPAN, END_SPAN, TAG, EVENT, SET_PARENT_CONTEXT, SET_TRACE_ID, SET_SPAN_ID :: MsgType +pattern BEGIN_SPAN, END_SPAN, TAG, EVENT, SET_PARENT_CONTEXT, SET_TRACE_ID, SET_SPAN_ID, DECLARE_INSTRUMENT, METRIC_CAPTURE :: MsgType pattern BEGIN_SPAN = MsgType 1 pattern END_SPAN = MsgType 2 pattern TAG = MsgType 3 @@ -35,6 +38,8 @@ pattern SET_PARENT_CONTEXT = MsgType 5 pattern SET_TRACE_ID = MsgType 6 pattern SET_SPAN_ID = MsgType 7 +pattern DECLARE_INSTRUMENT = MsgType 8 +pattern METRIC_CAPTURE = MsgType 9 {-# INLINE maxMsgLen #-} maxMsgLen :: Int @@ -70,6 +75,10 @@ nextLocalSpan :: MonadIO m => m SpanInFlight nextLocalSpan = liftIO $ (SpanInFlight . fromIntegral . hashUnique) <$> newUnique +{-# INLINE nextInstrumentId #-} +nextInstrumentId :: MonadIO m => m InstrumentId +nextInstrumentId = liftIO $ (fromIntegral . hashUnique) <$> newUnique + {-# INLINE builder_beginSpan #-} builder_beginSpan :: SpanInFlight -> BS.ByteString -> Builder builder_beginSpan (SpanInFlight u) operation = @@ -107,6 +116,39 @@ builder_setSpanId :: SpanInFlight -> SpanId -> Builder builder_setSpanId (SpanInFlight u) (SId sid) = header SET_SPAN_ID <> word64LE u <> word64LE sid +{-# INLINE builder_declareInstrument #-} +builder_declareInstrument :: Instrument s a m -> Builder +builder_declareInstrument instrument = + header DECLARE_INSTRUMENT <> + int8 (instrumentTag instrument) <> + word64LE (instrumentId instrument) <> + byteString (instrumentName instrument) + +{-# INLINE builder_captureMetric #-} +builder_captureMetric :: InstrumentId -> Int -> Builder +builder_captureMetric iId v = + header METRIC_CAPTURE <> + word64LE iId <> + int64LE (fromIntegral v) + {-# INLINE traceBuilder #-} traceBuilder :: MonadIO m => Builder -> m () traceBuilder = liftIO . traceBinaryEventIO . LBS.toStrict . toLazyByteString + +{-# INLINE instrumentTag #-} +instrumentTag :: Instrument s a m -> Int8 +instrumentTag Counter{} = 1 +instrumentTag UpDownCounter{} = 2 +instrumentTag ValueRecorder{} = 3 +instrumentTag SumObserver{} = 4 +instrumentTag UpDownSumObserver{} = 5 +instrumentTag ValueObserver{} = 6 + +{-# INLINE instrumentTagStr #-} +instrumentTagStr :: Instrument s a m -> String +instrumentTagStr Counter{} = "Counter" +instrumentTagStr UpDownCounter{} = "UpDownCounter" +instrumentTagStr ValueRecorder{} = "ValueRecorder" +instrumentTagStr SumObserver{} = "SumObserver" +instrumentTagStr UpDownSumObserver{} = "UpDownSumObserver" +instrumentTagStr ValueObserver{} = "ValueObserver" diff --git a/src/OpenTelemetry/Exporter.hs b/src/OpenTelemetry/Exporter.hs deleted file mode 100644 --- a/src/OpenTelemetry/Exporter.hs +++ /dev/null @@ -1,15 +0,0 @@ -module OpenTelemetry.Exporter where - -data ExportResult - = ExportSuccess - | ExportFailedRetryable - | ExportFailedNotRetryable - deriving (Show, Eq) - -data Exporter thing = Exporter - { export :: [thing] -> IO ExportResult, - shutdown :: IO () - } - -noopExporter :: Exporter whatever -noopExporter = Exporter (const (pure ExportFailedNotRetryable)) (pure ()) diff --git a/src/OpenTelemetry/Metrics_Internal.hs b/src/OpenTelemetry/Metrics_Internal.hs new file mode 100644 --- /dev/null +++ b/src/OpenTelemetry/Metrics_Internal.hs @@ -0,0 +1,134 @@ +{-| + +This is an internal module. The public interface is re-exported by "OpenTelemetry.Eventlog" + +This module implements the instruments of the metrics portion of the +OpenTelemetry API. It is reexported by "OpenTelemetry.Eventlog" and should be +used by importing that. + +The way to use the 'Instrument' type is throught the 'add', 'record' or +'observe' functions (depending on the instrument type) which capture metrics on +a given instrument. + +Usage: + +@ +import OpenTelemetry.Eventlog + +aCounter :: Counter +aCounter = Counter "myCounter" + +anObserver :: ValueObserver +anObserver = ValueObserver "myObserver" + +main :: IO () +main = do + add aCounter 3 + record anObserver 40 +@ + +-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE StandaloneDeriving #-} + +module OpenTelemetry.Metrics_Internal + ( Instrument(..) + , SomeInstrument(..) + -- * Synonyms for specific types of Instrument + , Counter + , UpDownCounter + , ValueRecorder + , SumObserver + , UpDownSumObserver + , ValueObserver + -- * Used for indexing Instrument. All possible combinations are covered + , Synchronicity(..) + , Additivity(..) + , Monotonicity(..) + , InstrumentName + , InstrumentId + , instrumentName + , instrumentId + ) where + +import Data.Hashable (Hashable(..)) +import Data.ByteString as BS +import Data.Word + +data Synchronicity = Synchronous | Asynchronous +data Additivity = Additive | NonAdditive +data Monotonicity = Monotonic | NonMonotonic + +type InstrumentName = BS.ByteString +type InstrumentId = Word64 + +type Counter = Instrument 'Synchronous 'Additive 'Monotonic +type UpDownCounter = Instrument 'Synchronous 'Additive 'NonMonotonic +type ValueRecorder = Instrument 'Synchronous 'NonAdditive 'NonMonotonic +type SumObserver = Instrument 'Asynchronous 'Additive 'Monotonic +type UpDownSumObserver = Instrument 'Asynchronous 'Additive 'NonMonotonic +type ValueObserver = Instrument 'Asynchronous 'NonAdditive 'NonMonotonic + +-- TODO: Support tags + +-- | An OpenTelemetry instrument as defined in the OpenTelemetry Metrics API +-- () +data Instrument (s :: Synchronicity) (a :: Additivity) (m :: Monotonicity) where + Counter :: InstrumentName -> InstrumentId -> Counter + UpDownCounter :: InstrumentName -> InstrumentId -> UpDownCounter + ValueRecorder :: InstrumentName -> InstrumentId -> ValueRecorder + SumObserver :: InstrumentName -> InstrumentId -> SumObserver + UpDownSumObserver :: InstrumentName -> InstrumentId -> UpDownSumObserver + ValueObserver :: InstrumentName -> InstrumentId -> ValueObserver + +-- | Existential wrapper for 'Instrument'. Use when the exact type of Instrument does not matter. +data SomeInstrument = forall s a m. SomeInstrument (Instrument s a m) + +instrumentName :: Instrument s a m -> InstrumentName +instrumentName (Counter n _) = n +instrumentName (UpDownCounter n _) = n +instrumentName (ValueRecorder n _) = n +instrumentName (SumObserver n _) = n +instrumentName (UpDownSumObserver n _) = n +instrumentName (ValueObserver n _) = n + +instrumentId :: Instrument s a m -> InstrumentId +instrumentId (Counter _ i) = i +instrumentId (UpDownCounter _ i) = i +instrumentId (ValueRecorder _ i) = i +instrumentId (SumObserver _ i) = i +instrumentId (UpDownSumObserver _ i) = i +instrumentId (ValueObserver _ i) = i + +deriving instance Show (Instrument s a m) +deriving instance Eq (Instrument s a m) + +instance Show SomeInstrument where + show (SomeInstrument i) = show i + +instance Eq SomeInstrument where + (SomeInstrument i1) == (SomeInstrument i2) = case (i1, i2) of + (Counter s1 id1, Counter s2 id2) -> s1 == s2 && id1 == id2 + (UpDownCounter s1 id1, UpDownCounter s2 id2) -> s1 == s2 && id1 == id2 + (ValueRecorder s1 id1, ValueRecorder s2 id2) -> s1 == s2 && id1 == id2 + (SumObserver s1 id1, SumObserver s2 id2) -> s1 == s2 && id1 == id2 + (UpDownSumObserver s1 id1, UpDownSumObserver s2 id2) -> s1 == s2 && id1 == id2 + (ValueObserver s1 id1, ValueObserver s2 id2) -> s1 == s2 && id1 == id2 + (_, _) -> False + +instance Hashable (Instrument s a m) where + hashWithSalt s i = s `hashWithSalt` (constructorIdx i) `hashWithSalt` (instrumentName i) + where + constructorIdx :: Instrument s a m -> Int + constructorIdx Counter{} = 0 + constructorIdx UpDownCounter{} = 1 + constructorIdx ValueRecorder{} = 2 + constructorIdx SumObserver{} = 3 + constructorIdx UpDownSumObserver{} = 4 + constructorIdx ValueObserver{} = 5 + +instance Hashable SomeInstrument where + hashWithSalt s (SomeInstrument i) = hashWithSalt s i