kiroku-otel (empty) → 0.1.0.0
raw patch · 4 files changed
+311/−0 lines, 4 filesdep +aesondep +basedep +bytestring
Dependencies added: aeson, base, bytestring, hs-opentelemetry-api, hs-opentelemetry-propagator-w3c, hspec, kiroku-otel, kiroku-store, text, time, uuid
Files
- CHANGELOG.md +16/−0
- kiroku-otel.cabal +68/−0
- src/Kiroku/Otel/TraceContext.hs +87/−0
- test/Main.hs +140/−0
+ CHANGELOG.md view
@@ -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.
+ kiroku-otel.cabal view
@@ -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
+ src/Kiroku/Otel/TraceContext.hs view
@@ -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": "<vendor entries, optional>"+> }++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
+ test/Main.hs view
@@ -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+ }