giles
5f06b5e8e0
otel/waterfall-rects folds a trace's spans into rect geometry (x by start offset, width by duration, y by depth via parent-link ancestor count); otel/waterfall folds those into an inline <svg> (one <rect>+<text> per span). Renders to real SVG markup via the html tag registry.
217 lines
9.7 KiB
Plaintext
217 lines
9.7 KiB
Plaintext
;; lib/host/otel.sx — OpenTelemetry in SX, P1: the span model + API.
|
||
;;
|
||
;; A TRACE is a COMPOSITION: a span is {:trace :span :parent :name :t0 :t1 :attrs
|
||
;; :events}, so a trace is a tree of spans (the same shape as an object's :body
|
||
;; composition). Later phases fold that tree into a waterfall (render-fold), OTLP
|
||
;; JSON (export-fold) and metrics (aggregate-fold). This phase gives us the model,
|
||
;; the dynamic parent stack that builds the tree, and a bounded in-memory ring
|
||
;; buffer — spans are cheap timed effects, NOT durable KV rows.
|
||
|
||
;; ── monotonic id + clock ─────────────────────────────────────────────
|
||
;; A simple process-monotonic counter gives collision-free ids without needing a
|
||
;; random source (Math.random/Date.now aren't available on this host).
|
||
(define otel/-id-counter 0)
|
||
(define otel/-next-id
|
||
(fn (prefix)
|
||
(begin
|
||
(set! otel/-id-counter (+ otel/-id-counter 1))
|
||
(str prefix otel/-id-counter))))
|
||
(define otel/gen-trace-id (fn () (otel/-next-id "trace-")))
|
||
(define otel/gen-span-id (fn () (otel/-next-id "span-")))
|
||
|
||
;; now-ns — real epoch time in NANOSECONDS (the unit OTLP wants for
|
||
;; start/endTimeUnixNano). The OCaml host exposes `clock-milliseconds`
|
||
;; (Unix.gettimeofday, epoch ms); we scale by 1e6. Wall clocks can step
|
||
;; backwards (NTP), so we clamp against a high-water mark: now-ns never
|
||
;; decreases, keeping span durations non-negative even across a clock step.
|
||
(define otel/-last-ns 0)
|
||
(define otel/now-ns
|
||
(fn ()
|
||
(let ((raw (* (clock-milliseconds) 1000000)))
|
||
(let ((t (if (> raw otel/-last-ns) raw otel/-last-ns)))
|
||
(begin
|
||
(set! otel/-last-ns t)
|
||
t)))))
|
||
|
||
;; ── the dynamic parent stack ─────────────────────────────────────────
|
||
;; head = the innermost (current) span context {:span id :trace id}. Pushing on
|
||
;; with-span entry / popping on exit is what turns lexical nesting into parent
|
||
;; links, so a trace tree falls out of ordinary call nesting.
|
||
(define otel/-stack (list))
|
||
(define otel/-push! (fn (ctx) (set! otel/-stack (cons ctx otel/-stack))))
|
||
(define otel/-pop! (fn () (set! otel/-stack (rest otel/-stack))))
|
||
(define otel/-top (fn () (if (= (len otel/-stack) 0) nil (first otel/-stack))))
|
||
|
||
(define otel/current-span
|
||
(fn () (let ((t (otel/-top))) (if t (get t :span) nil))))
|
||
(define otel/current-trace
|
||
(fn () (let ((t (otel/-top))) (if t (get t :trace) nil))))
|
||
|
||
;; ── the bounded ring buffer ──────────────────────────────────────────
|
||
;; Oldest → newest. record! appends and drops from the front once over cap, so the
|
||
;; buffer stays O(cap) no matter how many spans flow through. NOT persisted.
|
||
(define otel/-cap 1000)
|
||
(define otel/-ring (list))
|
||
(define otel/set-cap! (fn (n) (begin (set! otel/-cap n) nil)))
|
||
|
||
(define otel/record!
|
||
(fn (span)
|
||
(begin
|
||
(set! otel/-ring (append otel/-ring (list span)))
|
||
(if (> (len otel/-ring) otel/-cap)
|
||
(set! otel/-ring (slice otel/-ring (- (len otel/-ring) otel/-cap)))
|
||
nil)
|
||
span)))
|
||
|
||
(define otel/recent (fn () otel/-ring))
|
||
|
||
;; Clear the ring AND the parent stack — used between tests / requests.
|
||
(define otel/reset!
|
||
(fn ()
|
||
(begin
|
||
(set! otel/-ring (list))
|
||
(set! otel/-stack (list))
|
||
nil)))
|
||
|
||
;; ── -timed: the shared timed-effect core ─────────────────────────────
|
||
;; Records a span around (thunk): a fresh span id, the trace inherited from the
|
||
;; enclosing span (or a new trace at the root), the enclosing span as :parent, and
|
||
;; t0/t1 straddling the call. Pushes its context so nested spans see it as parent,
|
||
;; pops after, then records the finished span. `finalize` maps the thunk's result
|
||
;; to EXTRA attrs merged onto `attrs` (e.g. an http.status only known post-call).
|
||
;; Returns the thunk's value unchanged.
|
||
(define otel/-timed
|
||
(fn (name attrs finalize thunk)
|
||
(let ((parent-ctx (otel/-top)))
|
||
(let ((trace (if parent-ctx (get parent-ctx :trace) (otel/gen-trace-id)))
|
||
(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))))))))
|
||
|
||
;; with-span — a plain timed span; no result-derived attrs.
|
||
(define otel/with-span
|
||
(fn (name attrs thunk)
|
||
(otel/-timed name attrs (fn (r) {}) thunk)))
|
||
|
||
;; ── auto-instrument HTTP handlers ─────────────────────────────────────
|
||
;; A trace is a composition; a request handler is a timed effect. Wrap one Dream
|
||
;; route's handler so dispatching it records a root span "METHOD /route" with
|
||
;; {:http.method :http.route :http.status}. The status is only known after the
|
||
;; handler runs, so it's a finalize attr; the result is coerced the same way the
|
||
;; router coerces it, so a bare-string handler still reports 200. The raw handler
|
||
;; result is returned untouched so dr/run-route's own coercion is unchanged.
|
||
(define otel/instrument-route
|
||
(fn (r)
|
||
(let ((method (dream-route-method r))
|
||
(path (dream-route-path r))
|
||
(handler (dream-route-handler r)))
|
||
(dream-route method path
|
||
(fn (req)
|
||
(otel/-timed
|
||
(str method " " path)
|
||
{:http.method method :http.route path}
|
||
(fn (resp) {:http.status (dream-status (dream-coerce-response resp))})
|
||
(fn () (handler req))))))))
|
||
|
||
;; 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 <svg> 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 <g> (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 <svg> 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)))
|