opentelemetry 0.4.2 → 0.5.0
raw patch · 5 files changed
+188/−58 lines, 5 filesdep +ghc-trace-eventsdep +hashabledep ~base
Dependencies added: ghc-trace-events, hashable
Dependency ranges changed: base
Files
- opentelemetry.cabal +6/−2
- src/OpenTelemetry/Eventlog.hs +62/−49
- src/OpenTelemetry/Eventlog_Internal.hs +112/−0
- src/OpenTelemetry/Exporter.hs +4/−5
- src/OpenTelemetry/SpanContext.hs +4/−2
opentelemetry.cabal view
@@ -2,7 +2,7 @@ name: opentelemetry description: The OpenTelemetry Haskell Client https://opentelemetry.io category: OpenTelemetry-version: 0.4.2+version: 0.5.0 license-file: LICENSE license: Apache-2.0 author: Dmitry Ivanov@@ -48,8 +48,10 @@ library import: options build-depends:- base >= 4.11 && < 5,+ base >= 4.13 && < 5, bytestring,+ ghc-trace-events >= 0.1.0.1,+ hashable, exceptions hs-source-dirs: src exposed-modules:@@ -57,3 +59,5 @@ OpenTelemetry.Exporter OpenTelemetry.Propagation OpenTelemetry.Eventlog+ OpenTelemetry.Eventlog_Internal+
src/OpenTelemetry/Eventlog.hs view
@@ -1,69 +1,82 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-} -module OpenTelemetry.Eventlog where+module OpenTelemetry.Eventlog+ ( withSpan,+ withSpan_,+ setSpanId,+ setTraceId,+ setTag,+ addEvent,+ setParentSpanContext,+ SpanInFlight (..),+ )+where import Control.Monad.Catch import Control.Monad.IO.Class+import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8-import Data.Unique-import Data.Word-import Debug.Trace+import OpenTelemetry.Eventlog_Internal (SpanInFlight (..))+import qualified OpenTelemetry.Eventlog_Internal as I import OpenTelemetry.SpanContext-import Text.Printf-import Prelude hiding (span) --- TODO(divanov): replace traceEventIO with the bytestring based equivalent---- This is not a Span Id in terms of OpenTelemetry.--- It's unique only in scope of one process, not globally.-type ProcessLocalSpanSerialNumber = Word64--newtype SpanInFlight = SpanInFlight ProcessLocalSpanSerialNumber--beginSpan :: MonadIO m => String -> m SpanInFlight-beginSpan operation = do- u64 <- fromIntegral . hashUnique <$> liftIO newUnique- liftIO $ traceEventIO (printf "ot2 begin span %d %s" u64 operation)- pure $ SpanInFlight u64--endSpan :: MonadIO m => SpanInFlight -> m ()-endSpan (SpanInFlight u64) = liftIO $ traceEventIO (printf "ot2 end span %d" u64)--setTag :: MonadIO m => SpanInFlight -> String -> BS8.ByteString -> m ()-setTag (SpanInFlight u64) k v = liftIO $ traceEventIO (printf "ot2 set tag %d %s %s" u64 k (BS8.unpack v))--addEvent :: MonadIO m => SpanInFlight -> String -> BS8.ByteString -> m ()-addEvent (SpanInFlight u64) k v = liftIO $ traceEventIO (printf "ot2 add event %d %s %s" u64 k (BS8.unpack v))--setParentSpanContext :: MonadIO m => SpanInFlight -> SpanContext -> m ()-setParentSpanContext (SpanInFlight u64) (SpanContext (SId sid) (TId tid)) =- liftIO $ traceEventIO (printf "ot2 set parent %d %016x %016x" u64 tid sid)--setTraceId :: MonadIO m => SpanInFlight -> TraceId -> m ()-setTraceId (SpanInFlight u64) (TId tid) =- liftIO $ traceEventIO (printf "ot2 set traceid %d %016x" u64 tid)--setSpanId :: MonadIO m => SpanInFlight -> SpanId -> m ()-setSpanId (SpanInFlight u64) (SId sid) =- liftIO $ traceEventIO (printf "ot2 set spanid %d %016x" u64 sid)--withSpan :: forall m a. (MonadIO m, MonadMask m) => String -> (SpanInFlight -> m a) -> m a+{-# INLINE withSpan #-}+withSpan ::+ forall m a.+ (MonadIO m, MonadMask m) =>+ BS.ByteString ->+ (SpanInFlight -> m a) ->+ m a withSpan operation action = fst <$> generalBracket (liftIO $ beginSpan operation)- ( \span exitcase -> liftIO $ do+ ( \sp exitcase -> liftIO $ do case exitcase of ExitCaseSuccess _ -> pure () ExitCaseException e -> do- setTag span "error" "true"- setTag span "error.message" (BS8.pack $ show e)+ setTag sp "error" "true"+ setTag sp "error.message" (BS8.pack $ take I.maxMsgLen $ show e) ExitCaseAbort -> do- setTag span "error" "true"- setTag span "error.message" "abort"- liftIO $ endSpan span+ setTag sp "error" "true"+ setTag sp "error.message" "abort"+ liftIO $ endSpan sp ) action -withSpan_ :: (MonadIO m, MonadMask m) => String -> m a -> m a+{-# INLINE withSpan_ #-}+withSpan_ :: (MonadIO m, MonadMask m) => BS.ByteString -> m a -> m a withSpan_ operation action = withSpan operation (const action)++{-# INLINE setSpanId #-}+setSpanId :: MonadIO m => SpanInFlight -> SpanId -> m ()+setSpanId sp sid = I.traceBuilder $ I.builder_setSpanId sp sid++{-# INLINE setTraceId #-}+setTraceId :: MonadIO m => SpanInFlight -> TraceId -> m ()+setTraceId sp tid = I.traceBuilder $ I.builder_setTraceId sp tid++{-# INLINE beginSpan #-}+beginSpan :: MonadIO m => BS.ByteString -> m SpanInFlight+beginSpan operation = do+ u <- I.nextLocalSpan+ I.traceBuilder $ I.builder_beginSpan u operation+ pure u++{-# INLINE endSpan #-}+endSpan :: MonadIO m => SpanInFlight -> m ()+endSpan sp = I.traceBuilder $ I.builder_endSpan sp++{-# INLINE setTag #-}+setTag :: MonadIO m => SpanInFlight -> BS.ByteString -> BS.ByteString -> m ()+setTag sp k v = I.traceBuilder $ I.builder_setTag sp k v++{-# INLINE addEvent #-}+addEvent :: MonadIO m => SpanInFlight -> BS.ByteString -> BS.ByteString -> m ()+addEvent sp k v = I.traceBuilder $ I.builder_addEvent sp k v++{-# INLINE setParentSpanContext #-}+setParentSpanContext :: MonadIO m => SpanInFlight -> SpanContext -> m ()+setParentSpanContext sp ctx = I.traceBuilder $ I.builder_setParentSpanContext sp ctx
+ src/OpenTelemetry/Eventlog_Internal.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}++module OpenTelemetry.Eventlog_Internal where++import Control.Monad.IO.Class+import Data.Bits+import qualified Data.ByteString as BS+import Data.ByteString.Builder+import qualified Data.ByteString.Lazy as LBS+import Data.Char+import Data.Hashable+import Data.Unique+import Data.Word (Word64, Word8)+import Debug.Trace.Binary+import OpenTelemetry.SpanContext+import Prelude hiding (span)++-- This is not a Span Id in terms of OpenTelemetry.+-- It's unique only in scope of one process, not globally.+type ProcessLocalSpanSerialNumber = Word64++newtype SpanInFlight = SpanInFlight ProcessLocalSpanSerialNumber+ deriving (Show, Eq, Hashable)++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 = MsgType 1+pattern END_SPAN = MsgType 2+pattern TAG = MsgType 3+pattern EVENT = MsgType 4+pattern SET_PARENT_CONTEXT = MsgType 5+pattern SET_TRACE_ID = MsgType 6+pattern SET_SPAN_ID = MsgType 7++{-# INLINE maxMsgLen #-}+maxMsgLen :: Int+maxMsgLen = shift 2 16++{-# INLINE otelMagic #-}+otelMagic :: Int+otelMagic = v .|. t .|. o+ where+ !v = shift 3 16+ !t = shift (ord 'T') 8+ !o = ord 'O'++{-# INLINE header #-}+header :: MsgType -> Builder+header (MsgType msgType) = word32LE $ fromIntegral h+ where+ !h = m .|. otelMagic+ !m = shift ((fromIntegral msgType) :: Int) $ shift 3 3++headerSize :: Int+headerSize = fromIntegral $ LBS.length $ toLazyByteString (header TAG <> word64LE 0)++{-# INLINE checkSize #-}+checkSize :: Int -> m -> m+checkSize s next = do+ let !exceed = s + headerSize - maxMsgLen+ if exceed > 0+ then error $ "eventlog message size exceed 64k by " ++ show exceed+ else next++{-# INLINE nextLocalSpan #-}+nextLocalSpan :: MonadIO m => m SpanInFlight+nextLocalSpan = liftIO $ (SpanInFlight . fromIntegral . hashUnique) <$> newUnique++{-# INLINE builder_beginSpan #-}+builder_beginSpan :: SpanInFlight -> BS.ByteString -> Builder+builder_beginSpan (SpanInFlight u) operation =+ header BEGIN_SPAN <> word64LE u <> byteString operation++{-# INLINE builder_endSpan #-}+builder_endSpan :: SpanInFlight -> Builder+builder_endSpan (SpanInFlight u) = header END_SPAN <> word64LE u++{-# INLINE builder_key_value #-}+builder_key_value :: MsgType -> SpanInFlight -> BS.ByteString -> BS.ByteString -> Builder+builder_key_value msg (SpanInFlight u) k v =+ let klen = fromIntegral $ BS.length k+ vlen = fromIntegral $ BS.length v+ in header msg <> word64LE u <> word32LE klen <> word32LE vlen <> byteString k <> byteString v++{-# INLINE builder_setTag #-}+builder_setTag :: SpanInFlight -> BS.ByteString -> BS.ByteString -> Builder+builder_setTag = builder_key_value TAG++{-# INLINE builder_addEvent #-}+builder_addEvent :: SpanInFlight -> BS.ByteString -> BS.ByteString -> Builder+builder_addEvent = builder_key_value EVENT++{-# INLINE builder_setParentSpanContext #-}+builder_setParentSpanContext :: SpanInFlight -> SpanContext -> Builder+builder_setParentSpanContext (SpanInFlight u) (SpanContext (SId sid) (TId tid)) =+ header SET_PARENT_CONTEXT <> word64LE u <> word64LE sid <> word64LE tid++{-# INLINE builder_setTraceId #-}+builder_setTraceId :: SpanInFlight -> TraceId -> Builder+builder_setTraceId (SpanInFlight u) (TId tid) = header SET_TRACE_ID <> word64LE u <> word64LE tid++{-# INLINE builder_setSpanId #-}+builder_setSpanId :: SpanInFlight -> SpanId -> Builder+builder_setSpanId (SpanInFlight u) (SId sid) = header SET_SPAN_ID <> word64LE u <> word64LE sid++{-# INLINE traceBuilder #-}+traceBuilder :: MonadIO m => Builder -> m ()+traceBuilder = liftIO . traceBinaryEventIO . LBS.toStrict . toLazyByteString
src/OpenTelemetry/Exporter.hs view
@@ -6,11 +6,10 @@ | ExportFailedNotRetryable deriving (Show, Eq) -data Exporter thing- = Exporter- { export :: [thing] -> IO ExportResult,- shutdown :: IO ()- }+data Exporter thing = Exporter+ { export :: [thing] -> IO ExportResult,+ shutdown :: IO ()+ } noopExporter :: Exporter whatever noopExporter = Exporter (const (pure ExportFailedNotRetryable)) (pure ())
src/OpenTelemetry/SpanContext.hs view
@@ -1,19 +1,21 @@ {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} module OpenTelemetry.SpanContext where +import Data.Hashable import Data.Word import GHC.Generics import Text.Printf newtype TraceId = TId Word64- deriving (Eq, Ord, Generic)+ deriving (Eq, Ord, Generic, Hashable) instance Show TraceId where show (TId tid) = printf "(TId 0x%x)" tid newtype SpanId = SId Word64- deriving (Eq, Ord, Generic)+ deriving (Eq, Ord, Generic, Hashable) instance Show SpanId where show (SId sid) = printf "(SId 0x%x)" sid