diff --git a/just-some-usage-code-that-must-compile/SomeUsageOfImplicitApi.hs b/just-some-usage-code-that-must-compile/SomeUsageOfImplicitApi.hs --- a/just-some-usage-code-that-must-compile/SomeUsageOfImplicitApi.hs +++ b/just-some-usage-code-that-must-compile/SomeUsageOfImplicitApi.hs @@ -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 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.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 diff --git a/src/OpenTelemetry/Common.hs b/src/OpenTelemetry/Common.hs --- a/src/OpenTelemetry/Common.hs +++ b/src/OpenTelemetry/Common.hs @@ -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 diff --git a/src/OpenTelemetry/Debug.hs b/src/OpenTelemetry/Debug.hs new file mode 100644 --- /dev/null +++ b/src/OpenTelemetry/Debug.hs @@ -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) diff --git a/src/OpenTelemetry/Explicit.hs b/src/OpenTelemetry/Explicit.hs --- a/src/OpenTelemetry/Explicit.hs +++ b/src/OpenTelemetry/Explicit.hs @@ -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 diff --git a/src/OpenTelemetry/FileExporter.hs b/src/OpenTelemetry/FileExporter.hs --- a/src/OpenTelemetry/FileExporter.hs +++ b/src/OpenTelemetry/FileExporter.hs @@ -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 diff --git a/src/OpenTelemetry/Implicit.hs b/src/OpenTelemetry/Implicit.hs --- a/src/OpenTelemetry/Implicit.hs +++ b/src/OpenTelemetry/Implicit.hs @@ -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 #-} diff --git a/src/OpenTelemetry/Propagation.hs b/src/OpenTelemetry/Propagation.hs --- a/src/OpenTelemetry/Propagation.hs +++ b/src/OpenTelemetry/Propagation.hs @@ -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)] diff --git a/unit-tests/TestCommon.hs b/unit-tests/TestCommon.hs --- a/unit-tests/TestCommon.hs +++ b/unit-tests/TestCommon.hs @@ -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 diff --git a/unit-tests/TestPropagation.hs b/unit-tests/TestPropagation.hs --- a/unit-tests/TestPropagation.hs +++ b/unit-tests/TestPropagation.hs @@ -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"