diff --git a/lib/host/otel.sx b/lib/host/otel.sx index d80017ff..b42f6426 100644 --- a/lib/host/otel.sx +++ b/lib/host/otel.sx @@ -87,16 +87,30 @@ (span (otel/gen-span-id)) (parent (if parent-ctx (get parent-ctx :span) nil))) (let ((t0 (begin (otel/-push! {:span span :trace trace}) (otel/now-ns)))) - (let ((result (thunk))) - (let ((t1 (otel/now-ns))) - (begin - (otel/-pop!) - (otel/record! - {:trace trace :span span :parent parent :name name - :t0 t0 :t1 t1 - :attrs (merge attrs (finalize result)) - :events (list)}) - result)))))))) + ;; guard the body: on a raise, pop + record an ERROR span (status + + ;; exception event) as a SIDE EFFECT in a clause test that returns false, + ;; so the condition auto-propagates to the outer handler. (An explicit + ;; `(raise e)` inside a guard handler re-enters this guard and hangs.) + (guard (e ((begin + (let ((t1 (otel/now-ns))) + (begin + (otel/-pop!) + (otel/record! + {:trace trace :span span :parent parent :name name + :t0 t0 :t1 t1 :status "error" :attrs attrs + :events (list {:name "exception" :time t1 :message (str e)})}))) + false) + nil)) + (let ((result (thunk))) + (let ((t1 (otel/now-ns))) + (begin + (otel/-pop!) + (otel/record! + {:trace trace :span span :parent parent :name name + :t0 t0 :t1 t1 :status "ok" + :attrs (merge attrs (finalize result)) + :events (list)}) + result))))))))) ;; with-span — a plain timed span; no result-derived attrs. (define otel/with-span @@ -462,3 +476,34 @@ :url endpoint :headers {:content-type "application/json"} :body (otel/export-otlp-json spans)}))) + +;; ── P8: W3C traceparent context propagation ─────────────────────────── +;; traceparent = "---" (RFC: version 00, +;; trace-id 32 hex, parent-id 16 hex, flags 2 hex; low bit = sampled). Emitting it +;; on outbound inter-service calls and parsing it on inbound requests lets ONE +;; trace span multiple services. Our internal ids hex-encode via the OTLP helpers. +(define otel/format-traceparent + (fn (trace-id span-id) + (str "00-" (otel/-trace-hex trace-id) "-" (otel/-span-hex span-id) "-01"))) + +;; the traceparent for the CURRENT span (nil outside any span) — for outbound calls. +(define otel/current-traceparent + (fn () + (let ((t (otel/-top))) + (if (nil? t) nil (otel/format-traceparent (get t :trace) (get t :span)))))) + +;; parse an inbound traceparent → {:version :trace-id :parent-id :flags :sampled}; +;; nil if absent or malformed (wrong field count / hex widths). +(define otel/parse-traceparent + (fn (header) + (if (or (nil? header) (= header "")) + nil + (let ((parts (split header "-"))) + (if (= (len parts) 4) + (let ((ver (nth parts 0)) (tid (nth parts 1)) + (pid (nth parts 2)) (flags (nth parts 3))) + (if (and (= (len tid) 32) (= (len pid) 16)) + {:version ver :trace-id tid :parent-id pid :flags flags + :sampled (not (= flags "00"))} + nil)) + nil))))) diff --git a/lib/host/tests/otel.sx b/lib/host/tests/otel.sx index d71ee27a..8d3db84d 100644 --- a/lib/host/tests/otel.sx +++ b/lib/host/tests/otel.sx @@ -322,6 +322,53 @@ (host-ot-test "empty export has zero spans" (len (get (first (get (first (get (otel/export-otlp (list)) :resourceSpans)) :scopeSpans)) :spans)) 0) +;; ── P8: context propagation (W3C traceparent) + error spans ──────── +;; traceparent = "00-<32hex trace>-<16hex span>-"; round-trips. +(define host-ot-tp (otel/format-traceparent "trace-1" "span-1")) +(host-ot-test "traceparent format" + host-ot-tp (str "00-" (otel/-trace-hex "trace-1") "-" (otel/-span-hex "span-1") "-01")) +(define host-ot-tpp (otel/parse-traceparent host-ot-tp)) +(host-ot-test "parsed version" (get host-ot-tpp :version) "00") +(host-ot-test "trace-id round-trips" (get host-ot-tpp :trace-id) (otel/-trace-hex "trace-1")) +(host-ot-test "parent-id round-trips" (get host-ot-tpp :parent-id) (otel/-span-hex "span-1")) +(host-ot-test "sampled flag" (get host-ot-tpp :sampled) true) +(host-ot-test "malformed traceparent → nil" (otel/parse-traceparent "garbage") nil) +(host-ot-test "wrong-width traceparent → nil" (otel/parse-traceparent "00-abc-def-01") nil) +(host-ot-test "empty traceparent → nil" (otel/parse-traceparent "") nil) + +;; current-traceparent reflects the active span +(otel/reset!) +(otel/with-span "x" {} + (fn () + (begin + (host-ot-test "current-traceparent set inside a span" + (not (= (otel/current-traceparent) nil)) true) + (host-ot-test "current-traceparent has 4 dash-parts" + (len (split (otel/current-traceparent) "-")) 4) + nil))) +(host-ot-test "current-traceparent nil outside a span" (otel/current-traceparent) nil) + +;; error spans: a raising thunk records a span marked :status error + an event, +;; then re-raises (caught by the test's guard); the stack is left clean. +(otel/reset!) +(guard (e (else nil)) + (otel/with-span "boom" {} (fn () (raise "kaboom")))) +(host-ot-test "error span recorded" (len (otel/recent)) 1) +(define host-ot-err (first (otel/recent))) +(host-ot-test "error span status" (get host-ot-err :status) "error") +(host-ot-test "error span name" (get host-ot-err :name) "boom") +(host-ot-test "error span has one event" (len (get host-ot-err :events)) 1) +(host-ot-test "error event name" (get (first (get host-ot-err :events)) :name) "exception") +(host-ot-test "error event carries the message" + (contains? (str (get (first (get host-ot-err :events)) :message)) "kaboom") true) +(host-ot-test "stack cleared after an error span" (otel/current-span) nil) + +;; success spans are marked ok (and keep empty attrs when none given) +(otel/reset!) +(otel/with-span "ok-span" {} (fn () 1)) +(host-ot-test "success span status ok" (get (first (otel/recent)) :status) "ok") +(host-ot-test "success span keeps empty attrs" (get (first (otel/recent)) :attrs) {}) + (define host-ot-tests-run! (fn