shikumi-trace-otel 0.1.0.0 → 0.1.1.0
raw patch · 5 files changed
+286/−34 lines, 5 filesdep +aesondep ~shikumi-tracedep ~shikumi-trace-otelPVP ok
version bump matches the API change (PVP)
Dependencies added: aeson
Dependency ranges changed: shikumi-trace, shikumi-trace-otel
API changes (from Hackage documentation)
Files
- CHANGELOG.md +11/−0
- shikumi-trace-otel.cabal +6/−4
- src/Shikumi/Trace/LiveExport.hs +16/−11
- src/Shikumi/Trace/OpenTelemetry.hs +70/−16
- test/Main.hs +183/−3
CHANGELOG.md view
@@ -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
shikumi-trace-otel.cabal view
@@ -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
src/Shikumi/Trace/LiveExport.hs view
@@ -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
src/Shikumi/Trace/OpenTelemetry.hs view
@@ -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
test/Main.hs view
@@ -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