diff --git a/lib/host/otel.sx b/lib/host/otel.sx index 11194303..f74ce117 100644 --- a/lib/host/otel.sx +++ b/lib/host/otel.sx @@ -126,3 +126,91 @@ ;; Flatten nested route groups and instrument each route — the host/make-app seam. (define otel/instrument-routes (fn (routes) (map otel/instrument-route (dr/flatten-routes routes)))) + +;; ── P4: render-fold → SVG waterfall ─────────────────────────────────── +;; A trace is a tree of spans; a waterfall is a fold over that tree into SVG (the +;; same discipline as the compose render-fold: walk the structure, emit per node). +;; Layout: x ∝ (t0 − trace.t0), width ∝ duration, y ∝ depth (ancestor count via +;; parent links). Geometry is computed as plain rect data first (otel/waterfall- +;; rects, testable), then folded into markup (otel/waterfall). +(define otel/-row-h 18) +(define otel/-svg-w 640) +(define otel/-pad 4) + +;; all spans belonging to one trace, from the ring. +(define otel/trace-spans + (fn (trace-id) (filter (fn (s) (= (get s :trace) trace-id)) (otel/recent)))) + +(define otel/-span-by-id + (fn (spans id) (first (filter (fn (s) (= (get s :span) id)) spans)))) + +;; depth = number of ancestors reachable via :parent within this trace's spans. +(define otel/-depth + (fn (s spans) + (if (nil? (get s :parent)) + 0 + (let ((p (otel/-span-by-id spans (get s :parent)))) + (if (nil? p) 0 (+ 1 (otel/-depth p spans))))))) + +;; trace start = earliest t0; end = latest t1 (folds over the spans). +(define otel/-min-t0 + (fn (spans) (reduce (fn (m s) (min m (get s :t0))) (get (first spans) :t0) spans))) +(define otel/-max-t1 + (fn (spans) (reduce (fn (m s) (max m (get s :t1))) (get (first spans) :t1) spans))) + +;; a rect per span: {:span :name :depth :x :y :w}. x/width are scaled to the +;; drawable width; a zero-duration span still gets a 1px sliver so it's visible. +(define otel/waterfall-rects + (fn (trace-id) + (let ((spans (otel/trace-spans trace-id))) + (if (empty? spans) + (list) + (let ((t0 (otel/-min-t0 spans)) + (t1 (otel/-max-t1 spans)) + (iw (- otel/-svg-w (* 2 otel/-pad)))) + (let ((total (if (> (- t1 t0) 0) (- t1 t0) 1))) + (map + (fn (s) + (let ((d (otel/-depth s spans)) + (dur (- (get s :t1) (get s :t0)))) + (let ((raw-w (* (/ dur total) iw))) + {:span (get s :span) + :name (get s :name) + :depth d + :x (+ otel/-pad (* (/ (- (get s :t0) t0) total) iw)) + :y (+ otel/-pad (* d otel/-row-h)) + :w (if (> raw-w 1) raw-w 1)}))) + spans))))))) + +;; one (bar + label) per rect. +(define otel/-rect->g + (fn (r) + (quasiquote + (g + (rect :x (unquote (get r :x)) :y (unquote (get r :y)) + :width (unquote (get r :w)) :height (unquote (- otel/-row-h 2)) + :fill "#4c78a8" :rx 2) + (text :x (unquote (+ (get r :x) 3)) :y (unquote (+ (get r :y) 12)) + :font-size 10 :fill "#ffffff" (unquote (get r :name))))))) + +;; max depth across rects (0 when empty) → svg height. +(define otel/-max-depth + (fn (rects) (reduce (fn (m r) (max m (get r :depth))) 0 rects))) + +;; the trace as an inline waterfall. +(define otel/waterfall + (fn (trace-id) + (let ((rects (otel/waterfall-rects trace-id))) + (let ((h (+ (* 2 otel/-pad) (* (+ (otel/-max-depth rects) 1) otel/-row-h)))) + (quasiquote + (svg :width (unquote otel/-svg-w) :height (unquote h) + :xmlns "http://www.w3.org/2000/svg" + (splice-unquote (map otel/-rect->g rects)))))))) + +;; count nodes whose head symbol prints as `head` — a small SVG-tree assertion aid. +(define otel/-tree-count + (fn (tree head) + (if (list? tree) + (let ((self (if (and (not (empty? tree)) (= (str (first tree)) head)) 1 0))) + (reduce (fn (acc n) (+ acc (otel/-tree-count n head))) self tree)) + 0))) diff --git a/lib/host/tests/otel.sx b/lib/host/tests/otel.sx index 04261ab6..b55935c4 100644 --- a/lib/host/tests/otel.sx +++ b/lib/host/tests/otel.sx @@ -126,6 +126,45 @@ (host-ot-test "make-app traces the health request" (not (= host-ot-hs nil)) true) (host-ot-test "make-app health status 200" (get (get host-ot-hs :attrs) :http.status) 200) +;; ── P4: render-fold → SVG waterfall ──────────────────────────────── +;; A trace (tree of spans) folds into an : one per span, x by start +;; offset, width by duration, y by depth. Build a root with nested children. +(otel/reset!) +(otel/with-span "root" {} + (fn () + (begin + (otel/with-span "a" {} (fn () nil)) + (otel/with-span "b" {} (fn () (otel/with-span "b1" {} (fn () nil)))) + nil))) +(define host-ot-tid (get (first (otel/recent)) :trace)) +(define host-ot-rects (otel/waterfall-rects host-ot-tid)) +(define host-ot-rect-named + (fn (nm) (first (filter (fn (r) (= (get r :name) nm)) host-ot-rects)))) + +(host-ot-test "one rect per span" (len host-ot-rects) 4) +(host-ot-test "root depth 0" (get (host-ot-rect-named "root") :depth) 0) +(host-ot-test "child a depth 1" (get (host-ot-rect-named "a") :depth) 1) +(host-ot-test "grandchild b1 depth 2" (get (host-ot-rect-named "b1") :depth) 2) +(host-ot-test "nested span y greater than root y" + (> (get (host-ot-rect-named "a") :y) (get (host-ot-rect-named "root") :y)) true) +(host-ot-test "deeper nesting greater y" + (> (get (host-ot-rect-named "b1") :y) (get (host-ot-rect-named "b") :y)) true) +(host-ot-test "root x is the left pad (starts at trace t0)" + (get (host-ot-rect-named "root") :x) 4) +(host-ot-test "all widths positive" + (every? (fn (r) (> (get r :w) 0)) host-ot-rects) true) + +;; the SVG itself: an svg head with one rect + one label per span +(define host-ot-svg (otel/waterfall host-ot-tid)) +(host-ot-test "waterfall head is svg" (str (first host-ot-svg)) "svg") +(host-ot-test "svg has one rect per span" (otel/-tree-count host-ot-svg "rect") 4) +(host-ot-test "svg has one label per span" (otel/-tree-count host-ot-svg "text") 4) + +;; unknown trace → empty waterfall, still a valid svg +(host-ot-test "unknown trace has no rects" (len (otel/waterfall-rects "no-such-trace")) 0) +(host-ot-test "unknown trace still yields an svg" + (str (first (otel/waterfall "no-such-trace"))) "svg") + (define host-ot-tests-run! (fn