diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,16 @@ +# kiroku-otel changelog + +## 0.1.0.0 — 2026-05-23 + +### New Features + +- Initial release. Exposes `Kiroku.Otel.TraceContext` with two helpers: + - `injectTraceContext :: SpanContext -> EventData -> EventData` — encodes + the supplied `SpanContext` to W3C `traceparent` / `tracestate` strings + and merges them into the event's `metadata` JSON object. Existing keys + in `metadata` are preserved. + - `extractTraceContext :: RecordedEvent -> Maybe SpanContext` — reads + the same JSON keys back out and decodes them through + `OpenTelemetry.Propagator.W3CTraceContext.decodeSpanContext`. Returns + `Nothing` when `metadata` is absent, is not a JSON object, lacks a + `traceparent` key, or carries an unparseable value. Never throws. diff --git a/kiroku-otel.cabal b/kiroku-otel.cabal new file mode 100644 --- /dev/null +++ b/kiroku-otel.cabal @@ -0,0 +1,68 @@ +cabal-version: 3.0 +name: kiroku-otel +version: 0.1.0.0 +synopsis: + OpenTelemetry W3C trace-context helpers for Kiroku event metadata + +description: + Pure helpers to inject and extract W3C trace-context (@traceparent@ and + @tracestate@ header strings, per the W3C trace-context specification) + into and out of the @metadata@ JSONB column carried by every Kiroku + event. Provided as a sister package to keep @kiroku-store@ free of any + @hs-opentelemetry@ dependency; consumers opt in by depending on this + package directly. + +author: Nadeem Bitar +maintainer: nadeem@gmail.com +license: BSD-3-Clause +build-type: Simple +category: Database, Eventing, Observability +extra-doc-files: CHANGELOG.md +homepage: https://github.com/shinzui/kiroku +bug-reports: https://github.com/shinzui/kiroku/issues + +source-repository head + type: git + location: https://github.com/shinzui/kiroku.git + +common common + default-language: GHC2024 + default-extensions: + DeriveAnyClass + DuplicateRecordFields + OverloadedLabels + OverloadedStrings + + ghc-options: -Wall + +library + import: common + exposed-modules: Kiroku.Otel.TraceContext + build-depends: + , aeson >=2.1 && <2.3 + , base >=4.18 && <5 + , bytestring >=0.11 && <0.13 + , hs-opentelemetry-api >=0.3 && <0.4 + , hs-opentelemetry-propagator-w3c >=0.1 && <0.2 + , kiroku-store ^>=0.1 + , text >=2.0 && <2.2 + + hs-source-dirs: src + +test-suite kiroku-otel-test + import: common + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + , aeson >=2.1 && <2.3 + , base >=4.18 && <5 + , bytestring >=0.11 && <0.13 + , hs-opentelemetry-api + , hspec >=2.10 && <2.12 + , kiroku-otel + , kiroku-store ^>=0.1 + , text >=2.0 && <2.2 + , time >=1.12 && <1.15 + , uuid >=1.3 && <1.4 diff --git a/src/Kiroku/Otel/TraceContext.hs b/src/Kiroku/Otel/TraceContext.hs new file mode 100644 --- /dev/null +++ b/src/Kiroku/Otel/TraceContext.hs @@ -0,0 +1,87 @@ +{- | W3C trace-context helpers that read and write @traceparent@ / +@tracestate@ header strings inside Kiroku event metadata. + +The on-the-wire JSON shape inside the event's @metadata@ JSONB column is: + +> { +> "traceparent": "00-<32-hex traceId>-<16-hex spanId>-<2-hex flags>", +> "tracestate": "" +> } + +Other keys in @metadata@ are preserved by 'injectTraceContext'. +-} +module Kiroku.Otel.TraceContext ( + injectTraceContext, + extractTraceContext, +) where + +import Data.Aeson (Value (..)) +import Data.Aeson.Key qualified as Key +import Data.Aeson.KeyMap (KeyMap) +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString (ByteString) +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE +import GHC.IO (unsafePerformIO) +import Kiroku.Store.Types (EventData (..), RecordedEvent (..)) +import OpenTelemetry.Propagator.W3CTraceContext (decodeSpanContext, encodeSpanContext) +import OpenTelemetry.Trace.Core (SpanContext, wrapSpanContext) + +{- | Encode a 'SpanContext' as W3C @traceparent@ / @tracestate@ strings and +merge them into the @metadata@ JSON object of an 'EventData'. Existing +keys in @metadata@ are preserved; existing @traceparent@ / @tracestate@ +keys (if any) are overwritten — the W3C spec mandates exactly one of +each value per propagation. + +If the input @metadata@ is 'Nothing', or is a non-object JSON value, +the helper starts from an empty object before merging. + +This function is pure: it uses 'unsafePerformIO' to call +'encodeSpanContext', which is observably pure on the frozen span +returned by 'wrapSpanContext' (no shared mutable state, no exceptions). +The \"unsafe\" annotation is mandatory to bridge the propagator's +@IO@-typed encoder to the pure interface this module exposes. +-} +{-# NOINLINE injectTraceContext #-} +injectTraceContext :: SpanContext -> EventData -> EventData +injectTraceContext sc ed = + case ed of + EventData{metadata = oldMeta} -> + ed{metadata = Just (Object (mergeTraceContext sc oldMeta))} :: EventData + +{- | Pull a 'SpanContext' back out of a 'RecordedEvent'\'s @metadata@. +Returns 'Nothing' when @metadata@ is absent, is not a JSON object, +lacks a @traceparent@ key, or contains a @traceparent@ value that fails +W3C parsing. Never throws. +-} +extractTraceContext :: RecordedEvent -> Maybe SpanContext +extractTraceContext re = case re of + RecordedEvent{metadata = Just (Object o)} -> decodeFromObject o + _ -> Nothing + +-- --------------------------------------------------------------------------- +-- Internal helpers +-- --------------------------------------------------------------------------- + +mergeTraceContext :: SpanContext -> Maybe Value -> KeyMap Value +mergeTraceContext sc mMeta = + let (tp, ts) = unsafePerformIO (encodeSpanContext (wrapSpanContext sc)) + tpText = TE.decodeUtf8 tp + tsText = TE.decodeUtf8 ts + existing = case mMeta of + Just (Object o) -> o + _ -> KM.empty + withTp = KM.insert (Key.fromText (T.pack "traceparent")) (String tpText) existing + in if T.null tsText + then withTp + else KM.insert (Key.fromText (T.pack "tracestate")) (String tsText) withTp + +decodeFromObject :: KeyMap Value -> Maybe SpanContext +decodeFromObject o = do + String tpText <- KM.lookup (Key.fromText (T.pack "traceparent")) o + let tpBs :: ByteString + tpBs = TE.encodeUtf8 tpText + tsBs = case KM.lookup (Key.fromText (T.pack "tracestate")) o of + Just (String tsText) -> Just (TE.encodeUtf8 tsText) + _ -> Nothing + decodeSpanContext (Just tpBs) tsBs diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,140 @@ +module Main where + +import Data.Aeson qualified as Aeson +import Data.Aeson.Key qualified as Key +import Data.Aeson.KeyMap qualified as KM +import Data.Text qualified as T +import Data.UUID qualified as UUID +import Kiroku.Otel.TraceContext (extractTraceContext, injectTraceContext) +import Kiroku.Store.Types ( + EventData (..), + EventId (..), + EventType (..), + GlobalPosition (..), + RecordedEvent (..), + StreamId (..), + StreamVersion (..), + ) +import OpenTelemetry.Trace.Core ( + SpanContext (..), + traceFlagsFromWord8, + ) +import OpenTelemetry.Trace.Id ( + Base (..), + baseEncodedToSpanId, + baseEncodedToTraceId, + ) +import OpenTelemetry.Trace.TraceState qualified as TS +import Test.Hspec + +main :: IO () +main = hspec $ do + describe "TraceContext round-trip" $ do + it "encodes and decodes a SpanContext through metadata" $ do + let sc = mkTestSpanContext + ed0 = mkEmptyEventData + ed1 = injectTraceContext sc ed0 + stub = mkStubRecorded (eventDataMetadata ed1) + case extractTraceContext stub of + Just sc' -> do + traceId (sc' :: SpanContext) `shouldBe` traceId (sc :: SpanContext) + spanId (sc' :: SpanContext) `shouldBe` spanId (sc :: SpanContext) + traceFlags (sc' :: SpanContext) `shouldBe` traceFlags (sc :: SpanContext) + Nothing -> expectationFailure "expected Just SpanContext" + + it "preserves existing metadata keys" $ do + let baseMeta = + Aeson.object + [ (Key.fromText (T.pack "tenant"), Aeson.String (T.pack "acme")) + ] + ed0 = mkEmptyEventDataWithMeta (Just baseMeta) + ed1 = injectTraceContext mkTestSpanContext ed0 + case eventDataMetadata ed1 of + Just (Aeson.Object o) -> do + KM.lookup (Key.fromText (T.pack "tenant")) o + `shouldBe` Just (Aeson.String (T.pack "acme")) + KM.lookup (Key.fromText (T.pack "traceparent")) o + `shouldNotBe` Nothing + _ -> expectationFailure "metadata is not a JSON object" + + describe "extractTraceContext absence handling" $ do + it "returns Nothing when metadata is absent" $ + extractTraceContext (mkStubRecorded Nothing) `shouldBe` Nothing + + it "returns Nothing when metadata is empty" $ + extractTraceContext (mkStubRecorded (Just (Aeson.object []))) + `shouldBe` Nothing + + it "returns Nothing when traceparent is unparseable" $ + extractTraceContext + ( mkStubRecorded + ( Just + ( Aeson.object + [ (Key.fromText (T.pack "traceparent"), Aeson.String (T.pack "garbage")) + ] + ) + ) + ) + `shouldBe` Nothing + + describe "injectTraceContext overwrites prior trace keys" $ do + it "replaces an existing traceparent value" $ do + let preexisting = + Aeson.object + [ (Key.fromText (T.pack "traceparent"), Aeson.String (T.pack "00-aaaa-bbbb-00")) + , (Key.fromText (T.pack "tenant"), Aeson.String (T.pack "acme")) + ] + ed0 = mkEmptyEventDataWithMeta (Just preexisting) + ed1 = injectTraceContext mkTestSpanContext ed0 + case eventDataMetadata ed1 of + Just (Aeson.Object o) -> do + KM.lookup (Key.fromText (T.pack "tenant")) o + `shouldBe` Just (Aeson.String (T.pack "acme")) + KM.lookup (Key.fromText (T.pack "traceparent")) o + `shouldNotBe` Just (Aeson.String (T.pack "00-aaaa-bbbb-00")) + _ -> expectationFailure "metadata is not a JSON object" + +mkEmptyEventData :: EventData +mkEmptyEventData = mkEmptyEventDataWithMeta Nothing + +mkEmptyEventDataWithMeta :: Maybe Aeson.Value -> EventData +mkEmptyEventDataWithMeta meta = + EventData + { eventId = Nothing + , eventType = EventType (T.pack "X") + , payload = Aeson.Null + , metadata = meta + , causationId = Nothing + , correlationId = Nothing + } + +eventDataMetadata :: EventData -> Maybe Aeson.Value +eventDataMetadata EventData{metadata = m} = m + +mkStubRecorded :: Maybe Aeson.Value -> RecordedEvent +mkStubRecorded meta = + RecordedEvent + { eventId = EventId UUID.nil + , eventType = EventType (T.pack "X") + , streamVersion = StreamVersion 1 + , globalPosition = GlobalPosition 1 + , originalStreamId = StreamId 1 + , originalVersion = StreamVersion 1 + , payload = Aeson.Null + , metadata = meta + , causationId = Nothing + , correlationId = Nothing + , createdAt = read "2026-05-14 00:00:00 UTC" + } + +mkTestSpanContext :: SpanContext +mkTestSpanContext = + SpanContext + { traceFlags = traceFlagsFromWord8 0x01 + , isRemote = True + , traceId = + either error id (baseEncodedToTraceId Base16 "4bf92f3577b34da6a3ce929d0e0e4736") + , spanId = + either error id (baseEncodedToSpanId Base16 "00f067aa0ba902b7") + , traceState = TS.empty + }