opentelemetry 0.0.0.2 → 0.1.0

raw patch · 10 files changed

+167/−86 lines, 10 filesdep +directorydep +stmdep −attoparsecPVP ok

version bump matches the API change (PVP)

Dependencies added: directory, stm

Dependencies removed: attoparsec

API changes (from Hackage documentation)

Files

• just-some-usage-code-that-must-compile/SomeUsageOfImplicitApi.hs +4/−4
• opentelemetry.cabal +5/−3
• src/OpenTelemetry/Common.hs +37/−15
• src/OpenTelemetry/Debug.hs +21/−0
• src/OpenTelemetry/Explicit.hs +2/−3
• src/OpenTelemetry/FileExporter.hs +3/−1
• src/OpenTelemetry/Implicit.hs +76/−49
• src/OpenTelemetry/Propagation.hs +6/−2
• unit-tests/TestCommon.hs +7/−7
• unit-tests/TestPropagation.hs +6/−2

@@ -35,12 +35,12 @@    -- TODO: JSON values -  addEvent "rpc roundtrip begin"+  addEvent "log" "rpc roundtrip begin"   withSpan "leveraging synergies" $ do     threadDelay 10000-    addEvent "enough synergies leveraged"-  addEvent "All your base are belong to us"-  addEvent "rpc roundtrip end"+    addEvent "log" "enough synergies leveraged"+  addEvent "log" "All your base are belong to us"+  addEvent "log" "rpc roundtrip end"   withSpan "project" $ do     -- Connecting spans across threads requires some manual plumbing     sp <- getCurrentActiveSpan

@@ -2,7 +2,7 @@ name:                opentelemetry description:         The OpenTelemetry Haskell Client https://opentelemetry.io category:            OpenTelemetry-version:             0.0.0.2+version:             0.1.0 license-file:        LICENSE license:             Apache-2.0 author:              Dmitry Ivanov@@ -50,20 +50,22 @@   import: options   build-depends:     base >= 4.12 && < 5,-    attoparsec,     bytestring,     clock >= 0.8,+    directory,     exceptions,     hashable,     random >= 1.1,+    stm,     text,     unordered-containers   hs-source-dirs: src   exposed-modules:     OpenTelemetry.Common+    OpenTelemetry.Debug     OpenTelemetry.Explicit-    OpenTelemetry.Implicit     OpenTelemetry.FileExporter+    OpenTelemetry.Implicit     OpenTelemetry.Propagation  test-suite just-some-usage-code-that-must-compile

@@ -10,21 +10,27 @@ import qualified Data.Text as T import Data.Word import System.Clock+import Text.Printf  newtype TraceId = TId Word64-  deriving (Show, Eq, Generic)+  deriving (Eq, Generic)   deriving (Hashable) via Word64 +instance Show TraceId where+  show (TId tid) = printf "TraceId %x" tid+ newtype SpanId = SId Word64-  deriving (Show, Eq, Generic)+  deriving (Eq, Generic)   deriving (Hashable) via Word64 +instance Show SpanId where+  show (SId sid) = printf "SpanId %x" sid+ type Timestamp = Word64  data Tracer threadId   = Tracer-      { tracerSpanStacks :: !(HM.HashMap threadId (NE.NonEmpty Span)),-        trace2thread :: !(HM.HashMap TraceId threadId)+      { tracerSpanStacks :: !(HM.HashMap threadId (NE.NonEmpty Span))       }       deriving (Eq, Show) @@ -33,8 +39,7 @@   case HM.lookup tid tracerSpanStacks of     Nothing ->       let !stacks = HM.insert tid (sp :| []) tracerSpanStacks-          !t2t = HM.insert (spanTraceId sp) tid trace2thread-      in Tracer stacks t2t+      in Tracer stacks     Just sps ->       let !stacks = HM.insert tid (sp <| sps) tracerSpanStacks       in t { tracerSpanStacks = stacks }@@ -44,20 +49,20 @@   case HM.lookup tid tracerSpanStacks of     Nothing -> (Nothing, t)     Just (sp :| sps) ->-      let (stacks, t2t) =+      let stacks =             case NE.nonEmpty sps of-              Nothing -> (HM.delete tid tracerSpanStacks, HM.delete (spanTraceId sp) trace2thread)-              Just sps' -> (HM.insert tid sps' tracerSpanStacks, trace2thread)-       in (Just sp, Tracer stacks t2t)+              Nothing -> HM.delete tid tracerSpanStacks+              Just sps' -> HM.insert tid sps' tracerSpanStacks+       in (Just sp, Tracer stacks)  tracerGetCurrentActiveSpan :: (Hashable tid, Eq tid) => Tracer tid -> tid -> Maybe Span-tracerGetCurrentActiveSpan (Tracer stacks _) tid =+tracerGetCurrentActiveSpan (Tracer stacks) tid =   case HM.lookup tid stacks of     Nothing -> Nothing     Just (sp NE.:| _) -> Just sp  createTracer :: (Hashable tid, Eq tid) => IO (Tracer tid)-createTracer = pure $ Tracer mempty mempty+createTracer = pure $ Tracer mempty  data SpanContext = SpanContext !SpanId !TraceId   deriving (Show, Eq, Generic)@@ -75,6 +80,12 @@ instance ToTagValue String where   toTagValue = StringTagValue . T.pack +instance ToTagValue Bool where+  toTagValue = BoolTagValue++instance ToTagValue Int where+  toTagValue = IntTagValue+ data Span   = Span       { spanContext :: {-# UNPACK #-} !SpanContext,@@ -82,12 +93,14 @@         spanStartedAt :: !Timestamp,         spanFinishedAt :: !Timestamp,         spanTags :: !(HM.HashMap T.Text TagValue),-        spanStatus :: !SpanStatus+        spanEvents :: [SpanEvent],+        spanStatus :: !SpanStatus,+        spanParentId :: Maybe SpanId       }   deriving (Show, Eq)  emptySpan :: Span-emptySpan = Span (SpanContext (SId 0) (TId 0)) "" 0 0 mempty OK+emptySpan = Span (SpanContext (SId 0) (TId 0)) "" 0 0 mempty mempty OK Nothing  spanTraceId :: Span -> TraceId spanTraceId Span {spanContext = SpanContext _ tid} = tid@@ -95,6 +108,12 @@ spanId :: Span -> SpanId spanId Span {spanContext = SpanContext sid _} = sid +data SpanEvent = SpanEvent+  { spanEventTimestamp :: !Timestamp+  , spanEventKey :: !T.Text+  , spanEventValue :: !T.Text+  } deriving (Show, Eq)+ data SpanStatus = OK   deriving (Show, Eq) @@ -125,7 +144,10 @@       { otcSpanExporter :: Exporter Span       } +noopExporter :: Exporter whatever+noopExporter = Exporter (const (pure ExportFailedNotRetryable)) (pure ())+ now64 :: IO Timestamp now64 = do-  TimeSpec secs nsecs <- getTime Monotonic+  TimeSpec secs nsecs <- getTime Realtime   pure $! fromIntegral secs * 1_000_000_000 + fromIntegral nsecs

@@ -0,0 +1,21 @@+module OpenTelemetry.Debug where++import Control.Concurrent.STM+import Control.Monad.IO.Class+import System.Environment+import System.IO+import System.IO.Unsafe++dd_ :: Show a => String -> a -> IO ()+dd_ = unsafePerformIO $+  lookupEnv "OPENTELEMETRY_DEBUG" >>= \case+    Nothing -> pure $ \_ _ -> pure ()+    Just "0" -> pure $ \_ _ -> pure ()+    Just "false" -> pure $ \_ _ -> pure ()+    _ -> pure $ \s thing -> liftIO $ do+      hPutStr stderr (s <> ": ")+      hPutStrLn stderr (show thing)+{-# NOINLINE dd_ #-}++inc :: Int -> TVar Int -> IO ()+inc amount counterVar = atomically $ modifyTVar counterVar (+ amount)

@@ -11,7 +11,6 @@ import qualified Data.Text as T import GHC.Conc import OpenTelemetry.Common-import System.Clock import System.Random  data Client@@ -24,13 +23,13 @@ startRootSpan _tracer name = do   timestamp <- now64   sid <- randomIO-  pure $! Span (SpanContext (SId sid) (TId sid)) name timestamp 0 mempty OK+  pure $! Span (SpanContext (SId sid) (TId sid)) name timestamp 0 mempty mempty OK Nothing  startChildSpan :: Client -> Span -> T.Text -> IO Span startChildSpan _tracer parent name = do   timestamp <- now64   sid <- randomIO-  pure $! Span (SpanContext (SId sid) (spanTraceId parent)) name timestamp 0 mempty OK+  pure $! Span (SpanContext (SId sid) (spanTraceId parent)) name timestamp 0 mempty mempty OK (Just $ spanId parent)  endSpan :: Client -> Span -> IO () endSpan _tracer sp = do

@@ -14,6 +14,7 @@ showValue :: TagValue -> String showValue (StringTagValue s) = show s showValue (IntTagValue i) = show i+showValue _ = "\"unknown\""  showSpan :: Span -> String showSpan s@(Span {..}) =@@ -21,12 +22,13 @@       threadId = case HM.lookup "thread_id" spanTags of         Just (StringTagValue (T.stripPrefix "ThreadId " -> Just (readMaybe . T.unpack -> Just t))) -> t         Just (IntTagValue t) -> t-        _ -> fromIntegral tid+        _ -> 1       meta :: String       meta =         spanTags           & HM.toList           & map (\(k, v) -> ["\"", T.unpack k, "\":", showValue v])+          & ([printf "\"traceId\":\"%x\"" tid] :)           & intersperse [","]           & concat           & concat

@@ -7,43 +7,65 @@ import Control.Monad.Catch import Control.Monad.IO.Class import qualified Data.HashMap.Strict as HM-import qualified Data.List.NonEmpty as NE import Data.List.NonEmpty (NonEmpty ((:|))) import Data.Maybe import qualified Data.Text as T import OpenTelemetry.Common import OpenTelemetry.FileExporter+import System.Directory+import System.Environment import System.IO.Unsafe import System.Random+import Text.Printf +data SpanChildness = Root | ChildOf Span++data AutoTagError = DoAutoTagError | Don'tAutoTagError+ withSpan :: (MonadIO m, MonadMask m) => String -> m a -> m a-withSpan operation action = do+withSpan = generalWithSpan (WithSpanOptions Root DoAutoTagError)++data WithSpanOptions+  = WithSpanOptions+      { childness :: SpanChildness,+        autoTagError :: AutoTagError+      }++generalWithSpan :: (MonadIO m, MonadMask m) => WithSpanOptions -> String -> m a -> m a+generalWithSpan WithSpanOptions {childness, autoTagError} operation action = do   threadId <- liftIO myThreadId   sid <- liftIO randomIO   startedAt <- liftIO now64-  bracket-    ( liftIO $ modifyMVar_ globalSharedMutableState $ \GlobalSharedMutableState {..} -> do-        let !ctx = case HM.lookup threadId (tracerSpanStacks gTracer) of-              Nothing -> SpanContext (SId sid) (TId sid)-              Just ((spanContext -> SpanContext _ tid) :| _) -> SpanContext (SId sid) tid-            !sp = Span ctx (T.pack operation) startedAt 0 (HM.singleton "thread_id" (StringTagValue $ T.pack $ show threadId)) OK-            !tracer = tracerPushSpan gTracer threadId sp-        pure $! GlobalSharedMutableState gSpanExporter tracer-    )-    ( \_ -> do-        liftIO $ modifyMVar_ globalSharedMutableState $ \GlobalSharedMutableState {..} -> do-          let (mspan, tracer) = tracerPopSpan gTracer threadId-          case mspan of-            Nothing -> pure ()-            Just sp -> do-              finishedAt <- liftIO now64-              res <- export gSpanExporter [sp {spanFinishedAt = finishedAt}]-              case res of-                ExportSuccess -> pure ()-                _ -> error $ "exporting span failed: " <> show sp+  (result, ()) <-+    generalBracket+      ( liftIO $ modifyMVar_ globalSharedMutableState $ \GlobalSharedMutableState {..} -> do+          let (!mpsid, !ctx) = case (childness, HM.lookup threadId (tracerSpanStacks gTracer)) of+                (ChildOf parent, _) -> (Just (spanId parent), SpanContext (SId sid) (spanTraceId parent))+                (_, Nothing) -> (Nothing, SpanContext (SId sid) (TId sid))+                (_, Just ((spanContext -> SpanContext psid tid) :| _)) -> (Just psid, SpanContext (SId sid) tid)+              !sp = Span ctx (T.pack operation) startedAt 0 (HM.singleton "thread_id" (StringTagValue $ T.pack $ show threadId)) mempty OK mpsid+              !tracer = tracerPushSpan gTracer threadId sp           pure $! GlobalSharedMutableState gSpanExporter tracer-    )-    (\_ -> action) -- TODO(divanov): set error=true on exception+      )+      ( \_ exitcase -> do+          liftIO $ modifyMVar_ globalSharedMutableState $ \GlobalSharedMutableState {..} -> do+            let (mspan, tracer) = tracerPopSpan gTracer threadId+            case mspan of+              Nothing -> pure ()+              Just sp -> do+                finishedAt <- liftIO now64+                let sp' = case (exitcase, autoTagError) of+                      (ExitCaseSuccess {}, _) -> sp+                      (_, Don'tAutoTagError) -> sp+                      _ -> sp {spanTags = HM.insert "error" (BoolTagValue True) (spanTags sp)}+                res <- export gSpanExporter [sp' {spanFinishedAt = finishedAt}]+                case res of+                  ExportSuccess -> pure ()+                  _ -> error $ "exporting span failed: " <> show sp+            pure $! GlobalSharedMutableState gSpanExporter tracer+      )+      (\_ -> action)+  pure result  setTag :: forall value m. (MonadIO m, ToTagValue value) => T.Text -> value -> m () setTag k v =@@ -52,17 +74,30 @@         sp {spanTags = HM.insert k (toTagValue v) (spanTags sp)}     ) -addEvent :: forall m. MonadIO m => T.Text -> m ()-addEvent name = do-  tid <- liftIO myThreadId-  error "addEvent: not implemented"+addEvent :: forall m. MonadIO m => T.Text -> T.Text -> m ()+addEvent name value = do+  now <- liftIO now64+  modifyCurrentSpan+    ( \sp ->+        sp {spanEvents = SpanEvent now name value : spanEvents sp}+    ) +setParentSpanContext :: MonadIO m => SpanContext -> m ()+setParentSpanContext (SpanContext psid tid) =+  modifyCurrentSpan+    ( \sp ->+        sp+          { spanContext = SpanContext (spanId sp) tid,+            spanParentId = Just psid+          }+    )+ withOpenTelemetry :: (MonadIO m, MonadMask m) => OpenTelemetryConfig -> m a -> m a withOpenTelemetry OpenTelemetryConfig {..} action = do   bracket     ( liftIO $ do         tracer <- createTracer-        putMVar globalSharedMutableState (GlobalSharedMutableState otcSpanExporter tracer)+        modifyMVar_ globalSharedMutableState (\_ -> pure $ GlobalSharedMutableState otcSpanExporter tracer)         pure ()     )     (\_ -> liftIO $ shutdown otcSpanExporter)@@ -76,12 +111,17 @@  withZeroConfigOpenTelemetry :: (MonadIO m, MonadMask m) => m a -> m a withZeroConfigOpenTelemetry action = do-  -- TODO(divanov): crossplatformer temporary directory-  -- TODO(divanov): include program name and current date in the filename-  exporter <- liftIO $ createFileSpanExporter "/tmp/opentelemetry.trace.json"+  (now, prog_name, tmp_dir) <- liftIO $ (,,) <$> now64 <*> getProgName <*> getTemporaryDirectory+  exporter <- liftIO $ createFileSpanExporter $ printf "%s/%s-%d.trace.json" tmp_dir prog_name now   let otelConfig = OpenTelemetryConfig {otcSpanExporter = exporter}   withOpenTelemetry otelConfig action +getCurrentSpanContext :: MonadIO m => m (Maybe SpanContext)+getCurrentSpanContext = do+  tid <- liftIO myThreadId+  GlobalSharedMutableState {..} <- liftIO $ readMVar globalSharedMutableState+  pure $ spanContext <$> tracerGetCurrentActiveSpan gTracer tid+ getCurrentActiveSpan :: MonadIO m => m Span getCurrentActiveSpan = do   tid <- liftIO myThreadId@@ -102,23 +142,10 @@     )  withChildSpanOf :: (MonadIO m, MonadMask m) => Span -> String -> m a -> m a-withChildSpanOf parent operation action = do-  threadId <- liftIO myThreadId-  sid <- liftIO randomIO-  timestamp <- liftIO now64-  bracket-    ( liftIO $ modifyMVar_ globalSharedMutableState $ \GlobalSharedMutableState {..} -> do-        let threadId' = fromMaybe threadId $ HM.lookup (spanTraceId parent) (trace2thread gTracer)-        let !ctx = case HM.lookup threadId' (tracerSpanStacks gTracer) of-              Nothing -> SpanContext (SId sid) (TId sid)-              Just ((spanContext -> SpanContext _ tid) NE.:| _) -> SpanContext (SId sid) tid-            !sp = Span ctx (T.pack operation) timestamp 0 mempty OK-            !tracer = tracerPushSpan gTracer threadId sp-        pure $! GlobalSharedMutableState gSpanExporter tracer-    )-    (\_ -> pure ())-    (\_ -> action)+withChildSpanOf parent operation action = generalWithSpan (WithSpanOptions (ChildOf parent) DoAutoTagError) operation action  globalSharedMutableState :: MVar GlobalSharedMutableState-globalSharedMutableState = unsafePerformIO newEmptyMVar+globalSharedMutableState = unsafePerformIO $ do+  tracer <- createTracer+  newMVar (GlobalSharedMutableState noopExporter tracer) {-# NOINLINE globalSharedMutableState #-}

@@ -5,12 +5,10 @@ module OpenTelemetry.Propagation where  import Data.Word-import Data.Attoparsec.ByteString.Char8 import qualified Data.ByteString.Char8 as BS import Data.Char (ord) import Data.List (find) import Data.String-import Debug.Trace import GHC.Generics import OpenTelemetry.Common import Text.Printf@@ -36,6 +34,7 @@ renderSpanContext (SpanContext (SId sid) (TId tid)) =   BS.pack $ printf "00-%x-%x-00" tid sid +isLowerHexDigit :: Char -> Bool isLowerHexDigit (ord -> w) = (w >= 48 && w <= 57) || (w >= 97 && w <= 102)  fromHex :: BS.ByteString -> Maybe Word64@@ -45,3 +44,8 @@     go (Just !result) (ord -> d) | d >= 48 && d < 58 = Just $ result * 16 + fromIntegral d - 48     go (Just result) (ord -> d) | d >= 97 && d < 124 = Just $ result * 16 + fromIntegral d - 87     go _ _ = Nothing++data PropagationFormat = W3CTraceContext++inject :: PropagationFormat -> SpanContext -> [(String, BS.ByteString)]+inject W3CTraceContext ctx = [("traceparent", renderSpanContext ctx)]

@@ -1,19 +1,19 @@ module TestCommon where -import OpenTelemetry.Common import Data.Word+import OpenTelemetry.Common  prop_tracer_push_does_something :: Word64 -> Word64 -> Int -> Bool prop_tracer_push_does_something sid tid threadid =-  let tracer0 = Tracer mempty mempty-      sp0 = emptySpan { spanContext = SpanContext (SId sid) (TId tid) }+  let tracer0 = Tracer mempty+      sp0 = emptySpan {spanContext = SpanContext (SId sid) (TId tid)}       tracer1 = tracerPushSpan tracer0 threadid sp0-  in tracer0 /= tracer1+   in tracer0 /= tracer1  prop_tracer_push_pop :: Word64 -> Word64 -> Int -> Bool prop_tracer_push_pop sid tid threadid =-  let tracer0 = Tracer mempty mempty-      sp0 = emptySpan { spanContext = SpanContext (SId sid) (TId tid) }+  let tracer0 = Tracer mempty+      sp0 = emptySpan {spanContext = SpanContext (SId sid) (TId tid)}       tracer1 = tracerPushSpan tracer0 threadid sp0       (Just sp1, tracer2) = tracerPopSpan tracer1 threadid-  in tracer0 == tracer2 && sp0 == sp1+   in tracer0 == tracer2 && sp0 == sp1

@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}  module TestPropagation where @@ -12,17 +13,20 @@ prop_render_parse_roundtrip :: Word64 -> Word64 -> Bool prop_render_parse_roundtrip sid tid =   let c = SpanContext (SId sid) (TId tid)-   in Just c == extractSpanContextFromHeaders [("traceparent", renderSpanContext c)]+   in Just c == extractSpanContextFromHeaders @String [("traceparent", renderSpanContext c)] +unit_render_smoke :: Assertion unit_render_smoke =   renderSpanContext (SpanContext (SId 1) (TId 2)) @?= "00-2-1-00" +unit_parse_smoke :: Assertion unit_parse_smoke =-  extractSpanContextFromHeaders [("traceparent", "00-2-1-00")] @?= Just (SpanContext (SId 1) (TId 2))+  extractSpanContextFromHeaders @String [("traceparent", "00-2-1-00")] @?= Just (SpanContext (SId 1) (TId 2))  prop_fromHex :: Word64 -> Bool prop_fromHex x =   Just x == fromHex (BS.pack $ printf "%x" x) +unit_fromHex_smoke :: Assertion unit_fromHex_smoke =   Just 1 @?= fromHex "1"