giles
51d4224a55
Clamp against a high-water mark so the clock never steps backwards; span durations stay non-negative. Real ns-scale timestamps replace the P1 placeholder counter.
96 lines
4.5 KiB
Plaintext
96 lines
4.5 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)))
|
|
|
|
;; ── with-span: the timed-effect combinator ───────────────────────────
|
|
;; 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 with-spans see it as
|
|
;; parent, pops after, then records the finished span. Returns the thunk's value.
|
|
(define otel/with-span
|
|
(fn (name attrs 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 attrs :events (list)})
|
|
result))))))))
|