diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,17 @@ ## Unreleased +## 0.1.1.0 - 2026-07-05 + +### Changed + +- OpenTelemetry export now marks incomplete spans, exports error status for + recorded provider failures, reads the response model from recorded response + JSON, and avoids revisiting cyclic span references. +- Live export now flushes and shuts down its tracer provider with bracketed + cleanup even when export throws. +- Refreshed the internal `shikumi-trace` bound for the `0.2` series. + ## 0.1.0.0 - 2026-06-13 ### Added diff --git a/shikumi-trace-otel.cabal b/shikumi-trace-otel.cabal --- a/shikumi-trace-otel.cabal +++ b/shikumi-trace-otel.cabal @@ -1,6 +1,6 @@ cabal-version: 3.4 name: shikumi-trace-otel -version: 0.1.0.0 +version: 0.1.1.0 synopsis: OpenTelemetry export of shikumi hierarchical trace trees (EP-7) @@ -43,6 +43,7 @@ Shikumi.Trace.OpenTelemetry build-depends: + , aeson , base >=4.20 && <5 , containers , generic-lens @@ -52,7 +53,7 @@ , hs-opentelemetry-semantic-conventions >=1.40 && <2 , lens ^>=5.3 , scientific - , shikumi-trace ^>=0.1.0.0 + , shikumi-trace ^>=0.2.0.0 , text ^>=2.1 , time , unordered-containers @@ -64,13 +65,14 @@ main-is: Main.hs ghc-options: -threaded -with-rtsopts=-N build-depends: + , aeson , base , containers , hs-opentelemetry-api >=1.0 && <1.1 , hs-opentelemetry-exporter-in-memory >=1.0 && <1.1 , hs-opentelemetry-sdk >=1.0 && <1.1 - , shikumi-trace ^>=0.1.0.0 - , shikumi-trace-otel ^>=0.1.0.0 + , shikumi-trace ^>=0.2.0.0 + , shikumi-trace-otel ^>=0.1.1.0 , tasty , tasty-hunit , text diff --git a/src/Shikumi/Trace/LiveExport.hs b/src/Shikumi/Trace/LiveExport.hs --- a/src/Shikumi/Trace/LiveExport.hs +++ b/src/Shikumi/Trace/LiveExport.hs @@ -23,7 +23,8 @@ ) where -import Control.Monad.IO.Class (MonadIO) +import Control.Exception (bracket) +import Control.Monad.IO.Class (MonadIO, liftIO) import Data.String (fromString) import Data.Text (Text) import Data.Text qualified as T @@ -34,17 +35,21 @@ import Shikumi.Trace (TraceTree) import Shikumi.Trace.OpenTelemetry (exportTree) --- | Build a 'TracerProvider' around the given processor, export the tree through --- the shared 'exportTree' walker, then flush and shut the provider down. The --- shutdown flushes the batch processor, so spans have left by the time this --- returns. +-- | Build a 'TracerProvider' around the given processor, export the tree +-- through the shared 'exportTree' walker, then flush and shut the provider +-- down. The shutdown runs under 'bracket', so an exception thrown while +-- exporting still flushes buffered spans and releases the provider before +-- propagating to the caller. exportTreeWith :: (MonadIO m) => SpanProcessor -> Text -> TraceTree -> m () -exportTreeWith processor name tree = do - tp <- Otel.createTracerProvider [processor] Otel.emptyTracerProviderOptions - let tracer = Otel.makeTracer tp (fromString (T.unpack name)) Otel.tracerOptions - exportTree tracer tree - _ <- Otel.shutdownTracerProvider tp Nothing - pure () +exportTreeWith processor name tree = + liftIO $ + bracket + (Otel.createTracerProvider [processor] Otel.emptyTracerProviderOptions) + (\tp -> Otel.shutdownTracerProvider tp Nothing) + ( \tp -> do + let tracer = Otel.makeTracer tp (fromString (T.unpack name)) Otel.tracerOptions + exportTree tracer tree + ) -- | The live path: load OTLP config from the standard @OTEL_EXPORTER_OTLP_*@ -- environment variables (default endpoint @http:\/\/localhost:4318@), build the diff --git a/src/Shikumi/Trace/OpenTelemetry.hs b/src/Shikumi/Trace/OpenTelemetry.hs --- a/src/Shikumi/Trace/OpenTelemetry.hs +++ b/src/Shikumi/Trace/OpenTelemetry.hs @@ -5,27 +5,37 @@ -- depth-first and creates each child span in a 'Context' carrying its parent span -- (via 'OpenTelemetry.Context.insertSpan'), the explicit-context approach for -- reconstructing a recorded tree rather than discovering it from the live call --- stack. Each span's start/end times come from the recorded 'startedAt'/'endedAt'. +-- stack. Each span's start time comes from the recorded 'startedAt'. Closed +-- spans end at their recorded 'endedAt'; never-closed spans end at their own +-- start time and carry @shikumi.incomplete = true@. -- -- LM-call spans carry GenAI semantic-convention attributes -- (@gen_ai.provider.name@, @gen_ai.request.model@, @gen_ai.response.model@, -- @gen_ai.usage.input_tokens@, @gen_ai.usage.output_tokens@, --- @gen_ai.operation.name@); every span carries @shikumi.@-prefixed attributes --- (@shikumi.span_kind@, @shikumi.retries@, and, on LM-call spans, --- @shikumi.cost.usd@ / @shikumi.latency_ms@). +-- @gen_ai.operation.name@). The response model is read from the recorded +-- response's echoed @model.modelId@ and omitted when no response model is +-- present. Every span carries @shikumi.@-prefixed attributes +-- (@shikumi.span_kind@, @shikumi.retries@, optional @shikumi.incomplete@, and, +-- on LM-call spans, @shikumi.cost.usd@ / @shikumi.latency_ms@). module Shikumi.Trace.OpenTelemetry ( exportTree, ) where import Control.Lens ((^.)) +import Control.Monad (foldM) import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Aeson (Value (..)) +import Data.Aeson.KeyMap qualified as KM +import Data.Functor (($>)) import Data.Generics.Labels () import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict qualified as HashMap import Data.Int (Int64) import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe) import Data.Scientific qualified as Sci +import Data.Set qualified as Set import Data.Text (Text) import Data.Time (UTCTime) import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) @@ -43,18 +53,22 @@ -- structural ('ProgramSpan' / 'ModuleSpan' / 'CombinatorSpan') and LM-call -- ('LlmCallSpan') nodes alike become spans; nesting is preserved. exportTree :: (MonadIO m) => Otel.Tracer -> TraceTree -> m () -exportTree tracer tree = liftIO (go Context.empty (tree ^. #root)) +exportTree tracer tree = liftIO (go Set.empty Context.empty (tree ^. #root) $> ()) where smap = tree ^. #spans - go ctx sid = case Map.lookup sid smap of - Nothing -> pure () - Just s -> do - sp <- Otel.createSpan tracer ctx (s ^. #label) (argsFor s) - Otel.addAttributes sp (attrsFor s) - Otel.setStatus sp Otel.Ok - let childCtx = Context.insertSpan sp Context.empty - mapM_ (go childCtx) (childrenOf tree sid) - Otel.endSpan sp (utcToTimestamp <$> (s ^. #endedAt)) + go visited ctx sid + | Set.member sid visited = pure visited + | otherwise = case Map.lookup sid smap of + Nothing -> pure visited + Just s -> do + sp <- Otel.createSpan tracer ctx (s ^. #label) (argsFor s) + Otel.addAttributes sp (attrsFor s) + Otel.setStatus sp (statusFor s) + let childCtx = Context.insertSpan sp Context.empty + visited' = Set.insert sid visited + visited'' <- foldM (\vs c -> go vs childCtx c) visited' (childrenOf tree sid) + Otel.endSpan sp (Just (utcToTimestamp (endTimeOf s))) + pure visited'' argsFor :: Span -> Otel.SpanArguments argsFor s = @@ -72,10 +86,11 @@ attrsFor s = let a = s ^. #attrs base = - HashMap.fromList + HashMap.fromList $ [ ("shikumi.span_kind", Attr.toAttribute (kindText (s ^. #kind))), ("shikumi.retries", Attr.toAttribute (a ^. #retries)) ] + <> [("shikumi.incomplete", Attr.toAttribute True) | (s ^. #endedAt) == Nothing] withNode = maybe id @@ -89,12 +104,51 @@ genAiAttrs a m0 = maybe id (AttrMap.insertByKey SC.genAi_provider_name) (a ^. #provider) $ maybe id (AttrMap.insertByKey SC.genAi_request_model) (a ^. #model) $ - maybe id (AttrMap.insertByKey SC.genAi_response_model) (a ^. #model) $ + maybe id (AttrMap.insertByKey SC.genAi_response_model) (responseModelOf a) $ maybe id (\n -> AttrMap.insertByKey SC.genAi_usage_inputTokens (fromIntegral n :: Int64)) (a ^. #inputTokens) $ maybe id (\n -> AttrMap.insertByKey SC.genAi_usage_outputTokens (fromIntegral n :: Int64)) (a ^. #outputTokens) $ maybe id (\u -> HashMap.insert "shikumi.cost.usd" (Attr.toAttribute (Sci.toRealFloat u :: Double))) (a ^. #costUsd) $ maybe id (\l -> HashMap.insert "shikumi.latency_ms" (Attr.toAttribute (fromIntegral l :: Int))) (a ^. #latencyMs) $ AttrMap.insertByKey SC.genAi_operation_name ("chat" :: Text) m0 + +-- | The end instant to export. A span that never closed is exported with its +-- own start time rather than the wall clock at export time; 'attrsFor' marks +-- such spans with @shikumi.incomplete@. +endTimeOf :: Span -> UTCTime +endTimeOf s = fromMaybe (s ^. #startedAt) (s ^. #endedAt) + +-- | Status for an exported span. A recorded response that reports an in-band +-- provider failure becomes 'Otel.Error'; all other spans are explicitly marked +-- 'Otel.Ok'. +statusFor :: Span -> Otel.SpanStatus +statusFor s + | maybe False isErrorResponse (s ^. #attrs . #response) = + Otel.Error "recorded response reports an in-band provider error" + | otherwise = Otel.Ok + +-- | Whether a recorded baikai response JSON reports failure: a non-null +-- top-level @errorInfo@, a @message.stopReason@ of @\"error\"@, or a non-null +-- @message.errorMessage@. +isErrorResponse :: Value -> Bool +isErrorResponse (Object o) = + nonNull (KM.lookup "errorInfo" o) || messageErr (KM.lookup "message" o) + where + nonNull = maybe False (/= Null) + messageErr (Just (Object m)) = + KM.lookup "stopReason" m == Just (String "error") + || nonNull (KM.lookup "errorMessage" m) + messageErr _ = False +isErrorResponse _ = False + +-- | The model the provider says actually answered, read from the recorded +-- response's echoed @model.modelId@. 'Nothing' when no response was recorded +-- or the field is absent. +responseModelOf :: SpanAttrs -> Maybe Text +responseModelOf a = do + Object o <- a ^. #response + Object m <- KM.lookup "model" o + String mid <- KM.lookup "modelId" m + pure mid kindText :: SpanKind -> Text kindText = \case diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -6,14 +6,20 @@ -- non-root span's parent is another emitted span). module Main (main) where +import Control.Exception (SomeException, try) +import Data.Aeson (Value (..), object, (.=)) import Data.HashMap.Strict qualified as HashMap -import Data.IORef (IORef, readIORef) +import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Data.Map.Strict qualified as Map import Data.Maybe (catMaybes) import Data.Text (Text) import Data.Time (UTCTime) +import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) +import Data.Word (Word64) import OpenTelemetry.Attributes qualified as Attr +import OpenTelemetry.Common (OptionalTimestamp (..), Timestamp, mkTimestamp, timestampToOptional) import OpenTelemetry.Exporter.InMemory.Span (inMemoryListExporter) +import OpenTelemetry.Processor.Span (SpanProcessor (..)) import OpenTelemetry.Trace.Core qualified as Otel import OpenTelemetry.Trace.Id qualified as OtelId import Shikumi.Trace @@ -27,11 +33,22 @@ import Shikumi.Trace.LiveExport (exportTreeWith) import Shikumi.Trace.Node (NodePath (..), NodeStep (..)) import Shikumi.Trace.OpenTelemetry (exportTree) +import System.Timeout (timeout) import Test.Tasty (TestTree, defaultMain, testGroup) -import Test.Tasty.HUnit (assertBool, assertEqual, testCase) +import Test.Tasty.HUnit (assertBool, assertEqual, assertFailure, testCase, (@?=)) main :: IO () -main = defaultMain $ testGroup "shikumi-trace-otel" [nestingTest, liveExportInMemoryTest] +main = + defaultMain $ + testGroup + "shikumi-trace-otel" + [ nestingTest, + liveExportInMemoryTest, + exceptionReleasesProviderTest, + responseStatusAndModelTest, + openSpanTest, + cyclicTreeTest + ] nestingTest :: TestTree nestingTest = @@ -85,12 +102,98 @@ tagged <- mapM (spanHasAttr "shikumi.node_path") llmSpans assertBool "every LM-call span carries shikumi.node_path (EP-16 landed)" (and tagged) +exceptionReleasesProviderTest :: TestTree +exceptionReleasesProviderTest = + testCase "an exception during export still shuts the provider down" $ do + (proc0, _spansRef :: IORef [Otel.ImmutableSpan]) <- inMemoryListExporter + shutRef <- newIORef False + let proc' = + proc0 + { spanProcessorShutdown = writeIORef shutRef True >> spanProcessorShutdown proc0 + } + r <- try (exportTreeWith proc' "shikumi-exc-test" throwingTree) + case r of + Left (_ :: SomeException) -> pure () + Right () -> assertFailure "expected the trace label exception to propagate" + wasShut <- readIORef shutRef + assertBool "provider shutdown ran despite the exception" wasShut + +responseStatusAndModelTest :: TestTree +responseStatusAndModelTest = + testCase "error responses export as status Error; response model is honest" $ do + (tracer, getSpans) <- newTracerWithInMemory + exportTree tracer responseTree + emitted <- getSpans + errSpan <- findSpan "anthropic/error" emitted + okSpan <- findSpan "anthropic/success" emitted + errStatus <- spanStatus errSpan + case errStatus of + Otel.Error _ -> pure () + other -> assertFailure ("expected Error status, got " <> show other) + spanStatus okSpan >>= assertEqual "successful response status" Otel.Ok + errHasResponseModel <- spanHasAttr "gen_ai.response.model" errSpan + assertBool "error response without echoed model omits gen_ai.response.model" (not errHasResponseModel) + spanAttr "gen_ai.response.model" okSpan + >>= assertEqual + "response model comes from echoed response model" + (Just (Attr.toAttribute ("claude-sonnet-4-6-20250929" :: Text))) + +openSpanTest :: TestTree +openSpanTest = + testCase "a never-closed span exports as incomplete with zero duration" $ do + (tracer, getSpans) <- newTracerWithInMemory + exportTree tracer openSpanTree + emitted <- getSpans + assertEqual "one OTel span per tree node" (Map.size (spans openSpanTree)) (length emitted) + openSpan <- findSpan "predict:Draft" emitted + hasIncomplete <- spanHasAttr "shikumi.incomplete" openSpan + assertBool "open span carries shikumi.incomplete" hasIncomplete + spanEnd openSpan + >>= assertEqual + "open span ended at its own start timestamp" + (timestampToOptional (utcToTimestampForTest (at 2))) + +cyclicTreeTest :: TestTree +cyclicTreeTest = + testCase "a corrupt self-parented tree exports finitely" $ do + (tracer, getSpans) <- newTracerWithInMemory + r <- timeout 5000000 (exportTree tracer rootCyclicTree) + r @?= Just () + emitted <- getSpans + assertEqual "self-parented root exported once" 1 (length emitted) + assertBool "each span exported at most once" (length emitted <= Map.size (spans rootCyclicTree)) + -- | Whether the recorded span's attribute map contains a key. spanHasAttr :: Text -> Otel.ImmutableSpan -> IO Bool spanHasAttr key s = do hot <- readIORef (Otel.spanHot s) pure (HashMap.member key (Attr.getAttributeMap (Otel.hotAttributes hot))) +spanAttr :: Text -> Otel.ImmutableSpan -> IO (Maybe Attr.Attribute) +spanAttr key s = do + hot <- readIORef (Otel.spanHot s) + pure (HashMap.lookup key (Attr.getAttributeMap (Otel.hotAttributes hot))) + +spanStatus :: Otel.ImmutableSpan -> IO Otel.SpanStatus +spanStatus s = Otel.hotStatus <$> readIORef (Otel.spanHot s) + +spanEnd :: Otel.ImmutableSpan -> IO OptionalTimestamp +spanEnd s = Otel.hotEnd <$> readIORef (Otel.spanHot s) + +findSpan :: Text -> [Otel.ImmutableSpan] -> IO Otel.ImmutableSpan +findSpan name emitted = do + named <- + mapM + ( \s -> do + hot <- readIORef (Otel.spanHot s) + pure (Otel.hotName hot, s) + ) + emitted + case [s | (n, s) <- named, n == name] of + [] -> assertFailure ("missing span: " <> show name) + [s] -> pure s + _ -> assertFailure ("multiple spans named: " <> show name) + -- | The recorded parent span id of an immutable span, if it has a parent. parentSpanId :: Otel.ImmutableSpan -> IO (Maybe OtelId.SpanId) parentSpanId s = case Otel.spanParent s of @@ -125,6 +228,48 @@ ] } +throwingTree :: TraceTree +throwingTree = + TraceTree + { root = SpanId "s0", + spans = + Map.fromList + [ (SpanId "s0", node "s0" Nothing ProgramSpan (error "trace label exploded") emptyAttrs 0) + ] + } + +responseTree :: TraceTree +responseTree = + TraceTree + { root = SpanId "s0", + spans = + Map.fromList + [ (SpanId "s0", node "s0" Nothing ProgramSpan "responses" emptyAttrs 0), + (SpanId "s1", node "s1" (Just "s0") LlmCallSpan "anthropic/error" errorResponseAttrs 1), + (SpanId "s2", node "s2" (Just "s0") LlmCallSpan "anthropic/success" okResponseAttrs 2) + ] + } + +openSpanTree :: TraceTree +openSpanTree = + fixedTree + { spans = + Map.adjust + (\s -> s {endedAt = Nothing}) + (SpanId "s1") + (spans fixedTree) + } + +rootCyclicTree :: TraceTree +rootCyclicTree = + TraceTree + { root = SpanId "s0", + spans = + Map.fromList + [ (SpanId "s0", node "s0" (Just "s0") ProgramSpan "self-parented" emptyAttrs 0) + ] + } + node :: Text -> Maybe Text -> SpanKind -> Text -> SpanAttrs -> Int -> Span node sid par k lbl a n = Span @@ -149,5 +294,40 @@ nodePath = Just (NodePath [StepComposeL]) } +errorResponseAttrs :: SpanAttrs +errorResponseAttrs = + llmAttrs + { response = + Just + ( object + [ "errorInfo" .= object ["category" .= ("overloaded" :: Text)], + "message" .= object ["stopReason" .= ("error" :: Text)] + ] + ) + } + +okResponseAttrs :: SpanAttrs +okResponseAttrs = + llmAttrs + { response = + Just + ( object + [ "errorInfo" .= Null, + "message" .= object ["stopReason" .= ("stop" :: Text), "errorMessage" .= Null], + "model" .= object ["modelId" .= ("claude-sonnet-4-6-20250929" :: Text)] + ] + ) + } + at :: Int -> UTCTime at n = read ("2026-06-08 00:00:0" <> show n <> " UTC") + +utcToTimestampForTest :: UTCTime -> Timestamp +utcToTimestampForTest t = + let posix :: Rational + posix = toRational (utcTimeToPOSIXSeconds t) + secs :: Word64 + secs = floor posix + nanos :: Word64 + nanos = floor ((posix - toRational secs) * 1000000000) + in mkTimestamp secs nanos