Phase 3a complete: Observability (5 libraries, 131 tests passing)
ober
4618bcea75296aa0b64cfba7c5c25b6a3e7e9de6
new file mode 100644 --- /dev/null +++ b/lib/std/circuit.sls @@ -0,0 +1,170 @@ +#!chezscheme +;;; (std circuit) -- Circuit breaker pattern +;;; +;;; Three states: closed (normal), open (failing), half-open (probing). +;;; Config controls failure threshold, success threshold, and timeout. + +(library (std circuit) + (export + ;; Config + make-circuit-config + ;; Circuit breaker + make-circuit-breaker circuit-breaker? + circuit-call circuit-state circuit-reset! + circuit-open? circuit-closed? circuit-half-open? + circuit-stats) + + (import (chezscheme)) + + ;;; ========== Config record ========== + ;; failure-threshold — consecutive failures before opening + ;; success-threshold — consecutive successes in half-open to close + ;; timeout — seconds before half-open after opening + (define-record-type %circuit-config + (fields failure-threshold success-threshold timeout) + (protocol + (lambda (new) + (lambda args + ;; (make-circuit-config) + ;; (make-circuit-config failure-threshold success-threshold timeout) + (cond + [(null? args) + (new 5 1 60)] + [(= (length args) 3) + (new (car args) (cadr args) (caddr args))] + [else + (error 'make-circuit-config "expected 0 or 3 arguments")]))))) + + ;; Public constructor supports keyword-style too but we keep it simple: + ;; (make-circuit-config) or (make-circuit-config ft st timeout) + (define (make-circuit-config . args) + (cond + [(null? args) + (make-%circuit-config 5 1 60)] + [(= (length args) 3) + (apply make-%circuit-config args)] + [else + (error 'make-circuit-config "expected 0 or 3 arguments")])) + + ;;; ========== Circuit breaker record ========== + ;; state — mutable: 'closed | 'open | 'half-open + ;; failures — mutable: consecutive failure count + ;; successes — mutable: consecutive success count in half-open + ;; opened-at — mutable: time when opened (or #f) + ;; stats — mutable hashtable + (define-record-type %circuit-breaker + (fields config + (mutable state) + (mutable failures) + (mutable successes) + (mutable opened-at) + stats) + (protocol + (lambda (new) + (lambda (config) + (new config 'closed 0 0 #f + (let ([h (make-eq-hashtable)]) + (hashtable-set! h 'total-calls 0) + (hashtable-set! h 'total-failures 0) + (hashtable-set! h 'total-successes 0) + (hashtable-set! h 'state-transitions 0) + h)))))) + + (define (circuit-breaker? x) (%circuit-breaker? x)) + + (define (make-circuit-breaker . config-opt) + (let ([cfg (if (pair? config-opt) (car config-opt) (make-circuit-config))]) + (make-%circuit-breaker cfg))) + + ;;; ========== State accessors ========== + (define (circuit-state cb) (%circuit-breaker-state cb)) + (define (circuit-open? cb) (eq? (%circuit-breaker-state cb) 'open)) + (define (circuit-closed? cb) (eq? (%circuit-breaker-state cb) 'closed)) + (define (circuit-half-open? cb) (eq? (%circuit-breaker-state cb) 'half-open)) + + ;;; ========== Stats ========== + (define (circuit-stats cb) + (let ([h (%circuit-breaker-stats cb)]) + (list (cons 'total-calls (hashtable-ref h 'total-calls 0)) + (cons 'total-failures (hashtable-ref h 'total-failures 0)) + (cons 'total-successes (hashtable-ref h 'total-successes 0)) + (cons 'state-transitions (hashtable-ref h 'state-transitions 0)) + (cons 'state (%circuit-breaker-state cb))))) + + (define (stat-inc! cb key) + (let ([h (%circuit-breaker-stats cb)]) + (hashtable-set! h key (+ (hashtable-ref h key 0) 1)))) + + ;;; ========== State transitions ========== + (define (transition! cb new-state) + (%circuit-breaker-state-set! cb new-state) + (stat-inc! cb 'state-transitions)) + + (define (open-circuit! cb) + (%circuit-breaker-opened-at-set! cb (current-time)) + (%circuit-breaker-successes-set! cb 0) + (transition! cb 'open)) + + (define (close-circuit! cb) + (%circuit-breaker-failures-set! cb 0) + (%circuit-breaker-successes-set! cb 0) + (%circuit-breaker-opened-at-set! cb #f) + (transition! cb 'closed)) + + (define (maybe-half-open! cb) + ;; If open and timeout elapsed, move to half-open + (when (circuit-open? cb) + (let ([opened-at (%circuit-breaker-opened-at cb)]) + (when opened-at + (let* ([now (current-time)] + [elapsed (- (time-second now) (time-second opened-at))] + [timeout (%circuit-config-timeout (%circuit-breaker-config cb))]) + (when (>= elapsed timeout) + (%circuit-breaker-failures-set! cb 0) + (transition! cb 'half-open))))))) + + ;;; ========== circuit-call ========== + ;; Executes thunk according to circuit state. + ;; Returns thunk's value or raises on open circuit. + (define (circuit-call cb thunk) + (maybe-half-open! cb) + (let ([state (%circuit-breaker-state cb)]) + (cond + [(eq? state 'open) + (error 'circuit-call "circuit is open")] + [else + ;; closed or half-open: attempt the call + (stat-inc! cb 'total-calls) + (guard (exn [#t + ;; Record failure + (%circuit-breaker-failures-set! cb + (+ (%circuit-breaker-failures cb) 1)) + (stat-inc! cb 'total-failures) + (let* ([cfg (%circuit-breaker-config cb)] + [ft (%circuit-config-failure-threshold cfg)]) + (cond + [(eq? state 'half-open) + ;; Failure in half-open → reopen + (open-circuit! cb)] + [(>= (%circuit-breaker-failures cb) ft) + (open-circuit! cb)])) + (raise exn)]) + (let ([result (thunk)]) + ;; Success + (stat-inc! cb 'total-successes) + (%circuit-breaker-failures-set! cb 0) + (when (eq? state 'half-open) + (%circuit-breaker-successes-set! cb + (+ (%circuit-breaker-successes cb) 1)) + (when (>= (%circuit-breaker-successes cb) + (%circuit-config-success-threshold + (%circuit-breaker-config cb))) + (close-circuit! cb))) + result))]))) + + ;;; ========== circuit-reset! ========== + ;; Force the circuit back to closed state. + (define (circuit-reset! cb) + (close-circuit! cb)) + +) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/health.sls @@ -0,0 +1,117 @@ +#!chezscheme +;;; (std health) -- Health check framework +;;; +;;; Named checks return 'ok, 'degraded, or 'failing. +;;; run-checks executes all registered checks with duration tracking. +;;; health-status summarises to 'healthy, 'degraded, or 'failing. + +(library (std health) + (export + ;; Registry + make-health-registry health-registry? register-check! + ;; Running checks + run-checks health-status healthy? + ;; Check result accessors + check-result check-result-name check-result-status + check-result-message check-result-duration + ;; Check helpers + make-check with-timeout-check) + + (import (chezscheme)) + + ;;; ========== Check result record ========== + ;; status — 'ok | 'degraded | 'failing + ;; message — string or #f + ;; duration — milliseconds (exact integer) + (define-record-type %check-result + (fields name status message duration)) + + (define (check-result? x) (%check-result? x)) + (define (check-result-name r) (%check-result-name r)) + (define (check-result-status r) (%check-result-status r)) + (define (check-result-message r) (%check-result-message r)) + (define (check-result-duration r) (%check-result-duration r)) + + ;; Public constructor used in tests / direct construction + (define (check-result name status message duration) + (make-%check-result name status message duration)) + + ;;; ========== Registry ========== + ;; checks — mutable alist of (name . thunk) + (define-record-type %health-registry + (fields (mutable checks)) + (protocol (lambda (new) (lambda () (new '()))))) + + (define (health-registry? x) (%health-registry? x)) + (define (make-health-registry) (make-%health-registry)) + + (define (register-check! reg name thunk) + (%health-registry-checks-set! reg + (cons (cons name thunk) + (%health-registry-checks reg)))) + + ;;; ========== make-check ========== + ;; Wraps a thunk that should return 'ok, 'degraded, or 'failing. + ;; The thunk may also signal an error → treated as 'failing. + (define (make-check thunk) thunk) + + ;;; ========== with-timeout-check ========== + ;; Returns a new thunk; if the inner thunk takes longer than + ;; timeout-ms milliseconds, returns 'failing with a message. + ;; Because Chez Scheme portable threads may not have wall-clock + ;; preemption, we approximate using elapsed time after the call. + (define (with-timeout-check thunk timeout-ms) + (lambda () + (let* ([start (current-time)] + [result (guard (exn [#t 'failing]) (thunk))] + [end (current-time)] + [elapsed (time->ms end start)]) + (if (> elapsed timeout-ms) + 'failing + result)))) + + (define (time->ms t2 t1) + (let ([ds (- (time-second t2) (time-second t1))] + [dns (- (time-nanosecond t2) (time-nanosecond t1))]) + (+ (* ds 1000) (div dns 1000000)))) + + ;;; ========== run-checks ========== + ;; Returns a list of check-result records. + (define (run-checks reg) + (map (lambda (entry) + (let* ([name (car entry)] + [thunk (cdr entry)] + [start (current-time)] + [status (guard (exn [#t 'failing]) + (let ([r (thunk)]) + (if (memq r '(ok degraded failing)) + r + 'failing)))] + [end (current-time)] + [dur (time->ms end start)] + [msg (case status + ((ok) "check passed") + ((degraded) "check degraded") + ((failing) "check failed") + (else "unknown status"))]) + (make-%check-result name status msg dur))) + (reverse (%health-registry-checks reg)))) + + ;;; ========== health-status ========== + ;; 'healthy — all ok + ;; 'degraded — at least one degraded, none failing + ;; 'failing — at least one failing + (define (health-status results) + (let loop ([lst results] [worst 'healthy]) + (if (null? lst) + worst + (let ([s (%check-result-status (car lst))]) + (cond + [(eq? s 'failing) 'failing] + [(eq? s 'degraded) (loop (cdr lst) 'degraded)] + [else (loop (cdr lst) worst)]))))) + + (define (healthy? results) + (eq? (health-status results) 'healthy)) + +) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/log.sls @@ -0,0 +1,203 @@ +#!chezscheme +;;; (std log) -- Structured logging with sinks +;;; +;;; Provides log levels, structured fields, and pluggable sinks +;;; (console, file, JSON). The current logger is a thread-local +;;; parameter so dynamic scoping works naturally with `with-logger`. + +(library (std log) + (export + ;; Logger construction / inspection + make-logger logger? logger-level logger-fields + ;; Logging procedures + log-debug log-info log-warn log-error log-fatal + ;; Dynamic binding + with-logger current-logger + ;; Sink management + add-sink! make-console-sink make-file-sink make-json-sink + ;; Level predicate + log-level?) + + (import (chezscheme)) + + ;;; ========== Level ordering ========== + ;; debug=0 info=1 warn=2 error=3 fatal=4 + (define (level->int lvl) + (case lvl + ((debug) 0) + ((info) 1) + ((warn) 2) + ((error) 3) + ((fatal) 4) + (else (error 'log "unknown level" lvl)))) + + (define (level->string lvl) + (case lvl + ((debug) "DEBUG") + ((info) "INFO") + ((warn) "WARN") + ((error) "ERROR") + ((fatal) "FATAL") + (else "?"))) + + (define (log-level? x) + (and (memq x '(debug info warn error fatal)) #t)) + + ;;; ========== Logger record ========== + ;; level — minimum level to emit (symbol) + ;; sinks — mutable list of sink procedures + ;; fields — alist of global structured fields + (define-record-type %logger + (fields level (mutable sinks) fields) + (protocol + (lambda (new) + (lambda (level fields) + (new level '() fields))))) + + (define (logger? x) (%logger? x)) + (define (logger-level lg) (%logger-level lg)) + (define (logger-fields lg) (%logger-fields lg)) + + ;;; ========== Current logger parameter ========== + (define current-logger + (make-parameter #f)) + + (define-syntax with-logger + (syntax-rules () + [(_ lg body ...) + (parameterize ([current-logger lg]) + body ...)])) + + ;;; ========== make-logger ========== + ;; (make-logger level) — no extra fields + ;; (make-logger level k1 v1 …) — extra fields baked in + (define (make-logger level . kv) + (unless (log-level? level) + (error 'make-logger "invalid log level" level)) + (let loop ([lst kv] [fields '()]) + (if (null? lst) + (make-%logger level (reverse fields)) + (if (null? (cdr lst)) + (error 'make-logger "odd number of key/value arguments") + (loop (cddr lst) + (cons (cons (car lst) (cadr lst)) fields)))))) + + ;;; ========== add-sink! ========== + (define (add-sink! lg sink) + (%logger-sinks-set! lg (append (%logger-sinks lg) (list sink)))) + + ;;; ========== Internal: emit a log record ========== + ;; A record is an alist: + ;; (timestamp . <time>) (level . <symbol>) (message . <string>) + ;; followed by any extra fields. + (define (emit! lg level message extra-fields) + (when (>= (level->int level) (level->int (%logger-level lg))) + (let* ([ts (current-time)] + [rec (append + (list (cons 'timestamp ts) + (cons 'level level) + (cons 'message message)) + (%logger-fields lg) + extra-fields)]) + (for-each (lambda (sink) (sink rec)) (%logger-sinks lg))))) + + ;;; ========== Logging macros / procedures ========== + ;; (log-info logger "msg" 'key val …) + (define (parse-kv who lst) + (let loop ([lst lst] [acc '()]) + (if (null? lst) + (reverse acc) + (if (null? (cdr lst)) + (error who "odd number of key/value field arguments") + (loop (cddr lst) + (cons (cons (car lst) (cadr lst)) acc)))))) + + (define (log-at level lg msg . kv) + (let ([logger (or lg (current-logger))]) + (unless logger + (error 'log "no current logger — pass a logger or use with-logger")) + (emit! logger level msg (parse-kv 'log-at kv)))) + + (define (log-debug lg msg . kv) (apply log-at 'debug lg msg kv)) + (define (log-info lg msg . kv) (apply log-at 'info lg msg kv)) + (define (log-warn lg msg . kv) (apply log-at 'warn lg msg kv)) + (define (log-error lg msg . kv) (apply log-at 'error lg msg kv)) + (define (log-fatal lg msg . kv) (apply log-at 'fatal lg msg kv)) + + ;;; ========== Sinks ========== + + ;; Timestamp → "HH:MM:SS" approximation using seconds + (define (time->string ts) + (let* ([secs (time-second ts)] + [h (mod (div secs 3600) 24)] + [m (mod (div secs 60) 60)] + [s (mod secs 60)]) + (format "~2,'0d:~2,'0d:~2,'0d" h m s))) + + ;; Console sink: "[LEVEL] HH:MM:SS message key=val …" + (define (make-console-sink . port-opt) + (let ([port (if (pair? port-opt) (car port-opt) (current-output-port))]) + (lambda (rec) + (let ([level (cdr (assq 'level rec))] + [ts (cdr (assq 'timestamp rec))] + [msg (cdr (assq 'message rec))]) + (let ([fields (filter (lambda (p) + (not (memq (car p) '(timestamp level message)))) + rec)]) + (fprintf port "[~a] ~a ~a" + (level->string level) + (time->string ts) + msg) + (for-each (lambda (p) + (fprintf port " ~a=~s" (car p) (cdr p))) + fields) + (newline port) + (flush-output-port port)))))) + + ;; File sink: same format as console but to a file path + (define (make-file-sink path) + (let ([port (open-file-output-port + path + (file-options append) + (buffer-mode line) + (make-transcoder (utf-8-codec)))]) + (make-console-sink port))) + + ;; JSON sink: one JSON object per line + (define (make-json-sink . port-opt) + (let ([port (if (pair? port-opt) (car port-opt) (current-output-port))]) + (lambda (rec) + (display "{" port) + (let loop ([pairs rec] [first? #t]) + (unless (null? pairs) + (unless first? (display "," port)) + (let ([k (car (car pairs))] + [v (cdr (car pairs))]) + (fprintf port "\"~a\":~a" k (json-encode v port))) + (loop (cdr pairs) #f))) + (display "}" port) + (newline port) + (flush-output-port port)))) + + (define (json-encode v port) + (cond + [(string? v) (format "\"~a\"" (json-escape v))] + [(symbol? v) (format "\"~a\"" (symbol->string v))] + [(number? v) (number->string v)] + [(boolean? v) (if v "true" "false")] + [(time? v) (format "~s" (time-second v))] + [else (format "\"~a\"" v)])) + + (define (json-escape s) + ;; Escape double-quotes and backslashes + (let loop ([i 0] [acc '()]) + (if (= i (string-length s)) + (list->string (reverse acc)) + (let ([c (string-ref s i)]) + (loop (+ i 1) + (case c + ((#\") (cons #\" (cons #\\ acc))) + ((#\\) (cons #\\ (cons #\\ acc))) + (else (cons c acc)))))))) + +) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/metrics.sls @@ -0,0 +1,223 @@ +#!chezscheme +;;; (std metrics) -- Metrics collection: counters, gauges, histograms +;;; +;;; Prometheus-compatible metrics registry with text exposition format. + +(library (std metrics) + (export + ;; Registry + make-registry registry? registry-collect default-registry + ;; Counter + make-counter counter? counter-inc! counter-add! counter-value + ;; Gauge + make-gauge gauge? gauge-set! gauge-inc! gauge-dec! gauge-value + ;; Histogram + make-histogram histogram? histogram-observe! + histogram-count histogram-sum histogram-buckets + ;; Exposition + prometheus-format) + + (import (chezscheme)) + + ;;; ========== Registry ========== + ;; Holds a mutable list of metric objects. + (define-record-type %registry + (fields (mutable metrics)) + (protocol (lambda (new) (lambda () (new '()))))) + + (define (make-registry) (make-%registry)) + (define (registry? x) (%registry? x)) + + (define (registry-register! reg metric) + (%registry-metrics-set! reg + (cons metric (%registry-metrics reg)))) + + (define (registry-collect reg) + ;; Returns a list of all metric objects + (reverse (%registry-metrics reg))) + + (define default-registry (make-%registry)) + + ;;; ========== Labels helper ========== + ;; Labels are stored as an alist: (("name" . "value") …) + ;; We keep label-names on the metric descriptor. + + ;;; ========== Counter ========== + ;; name, help, label-names, value (mutable) + (define-record-type %counter + (fields name help label-names (mutable value)) + (protocol + (lambda (new) + (lambda (name help label-names) + (new name help label-names 0))))) + + (define (counter? x) (%counter? x)) + + (define (make-counter reg name help . label-names-opt) + (let* ([lnames (if (pair? label-names-opt) (car label-names-opt) '())] + [c (make-%counter name help lnames)]) + (when reg (registry-register! reg c)) + c)) + + (define (counter-value c) (%counter-value c)) + + (define (counter-inc! c . labels-opt) + ;; labels-opt is ignored in this simple implementation (no label instances) + (%counter-value-set! c (+ (%counter-value c) 1))) + + (define (counter-add! c n . labels-opt) + (when (< n 0) (error 'counter-add! "counter cannot decrease" n)) + (%counter-value-set! c (+ (%counter-value c) n))) + + ;;; ========== Gauge ========== + (define-record-type %gauge + (fields name help label-names (mutable value)) + (protocol + (lambda (new) + (lambda (name help label-names) + (new name help label-names 0))))) + + (define (gauge? x) (%gauge? x)) + + (define (make-gauge reg name help . label-names-opt) + (let* ([lnames (if (pair? label-names-opt) (car label-names-opt) '())] + [g (make-%gauge name help lnames)]) + (when reg (registry-register! reg g)) + g)) + + (define (gauge-value g) (%gauge-value g)) + (define (gauge-set! g v) (%gauge-value-set! g v)) + (define (gauge-inc! g . opt) (%gauge-value-set! g (+ (%gauge-value g) (if (pair? opt) (car opt) 1)))) + (define (gauge-dec! g . opt) (%gauge-value-set! g (- (%gauge-value g) (if (pair? opt) (car opt) 1)))) + + ;;; ========== Histogram ========== + ;; buckets — sorted list of upper-bound thresholds (numbers) + ;; bucket-counts — mutable vector, one count per bucket + 1 for +Inf + ;; count-val, sum-val — mutable totals + (define-record-type %histogram + (fields name help label-names + buckets + (mutable bucket-counts) + (mutable count-val) + (mutable sum-val)) + (protocol + (lambda (new) + (lambda (name help label-names buckets) + (new name help label-names buckets + (make-vector (+ (length buckets) 1) 0) + 0 + 0))))) + + (define histogram? %histogram?) + + (define default-buckets '(0.005 0.01 0.025 0.05 0.1 0.25 0.5 1.0 2.5 5.0 10.0)) + + (define (make-histogram reg name help . args) + ;; args: [label-names] [buckets: list] + ;; We accept (make-histogram reg name help) or + ;; (make-histogram reg name help label-names) or + ;; (make-histogram reg name help label-names buckets) + (let* ([label-names (if (and (pair? args) (list? (car args)) (or (null? (car args)) (string? (caar args)))) + (car args) '())] + [rest (if (and (pair? args) (list? (car args)) (or (null? (car args)) (string? (caar args)))) + (cdr args) args)] + [buckets (if (pair? rest) (car rest) default-buckets)] + [sorted (sort < buckets)] + [h (make-%histogram name help label-names sorted)]) + (when reg (registry-register! reg h)) + h)) + + (define (histogram-observe! h v) + (let* ([bs (%histogram-buckets h)] + [bv (%histogram-bucket-counts h)] + [n (length bs)]) + ;; Prometheus cumulative buckets: for each bucket le_i, if v <= le_i + ;; then increment that bucket. +Inf (index n) always gets incremented. + (let loop ([i 0] [lst bs]) + (unless (null? lst) + (when (<= v (car lst)) + (vector-set! bv i (+ (vector-ref bv i) 1))) + (loop (+ i 1) (cdr lst)))) + ;; +Inf always counts + (vector-set! bv n (+ (vector-ref bv n) 1)) + (%histogram-count-val-set! h (+ (%histogram-count-val h) 1)) + (%histogram-sum-val-set! h (+ (%histogram-sum-val h) v)))) + + (define (histogram-count h) (%histogram-count-val h)) + (define (histogram-sum h) (%histogram-sum-val h)) + (define (histogram-buckets h) + ;; Returns alist of (upper-bound . count) including +inf + (let* ([bs (%histogram-buckets h)] + [bv (%histogram-bucket-counts h)]) + (let loop ([i 0] [lst bs] [acc '()]) + (if (null? lst) + (reverse (cons (cons '+inf (vector-ref bv (length bs))) acc)) + (loop (+ i 1) (cdr lst) + (cons (cons (car lst) (vector-ref bv i)) acc)))))) + + ;;; ========== Prometheus text format ========== + + (define (prometheus-format reg . port-opt) + (let* ([port (if (pair? port-opt) (car port-opt) #f)] + [out (open-output-string)]) + (for-each + (lambda (m) + (cond + [(counter? m) (write-counter m out)] + [(gauge? m) (write-gauge m out)] + [(histogram? m) (write-histogram m out)])) + (registry-collect reg)) + (let ([s (get-output-string out)]) + (when port (display s port)) + s))) + + (define (write-metric-header type m port) + (fprintf port "# HELP ~a ~a\n# TYPE ~a ~a\n" + (%counter-name m) ; works for gauge/histogram too via duck + (metric-help m) + (metric-name m) + type)) + + (define (metric-name m) + (cond [(counter? m) (%counter-name m)] + [(gauge? m) (%gauge-name m)] + [(histogram? m) (%histogram-name m)])) + + (define (metric-help m) + (cond [(counter? m) (%counter-help m)] + [(gauge? m) (%gauge-help m)] + [(histogram? m) (%histogram-help m)])) + + (define (write-counter c port) + (fprintf port "# HELP ~a ~a\n# TYPE ~a counter\n~a ~a\n" + (%counter-name c) + (%counter-help c) + (%counter-name c) + (%counter-name c) + (%counter-value c))) + + (define (write-gauge g port) + (fprintf port "# HELP ~a ~a\n# TYPE ~a gauge\n~a ~a\n" + (%gauge-name g) + (%gauge-help g) + (%gauge-name g) + (%gauge-name g) + (%gauge-value g))) + + (define (write-histogram h port) + (let ([name (%histogram-name h)]) + (fprintf port "# HELP ~a ~a\n# TYPE ~a histogram\n" + name (%histogram-help h) name) + (for-each + (lambda (bkt) + (let ([bound (car bkt)] + [cnt (cdr bkt)]) + (if (eq? bound '+inf) + (fprintf port "~a_bucket{le=\"+Inf\"} ~a\n" name cnt) + (fprintf port "~a_bucket{le=\"~a\"} ~a\n" name bound cnt)))) + (histogram-buckets h)) + (fprintf port "~a_count ~a\n~a_sum ~a\n" + name (%histogram-count-val h) + name (%histogram-sum-val h)))) + +) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/span.sls @@ -0,0 +1,175 @@ +#!chezscheme +;;; (std span) -- Distributed tracing: spans and trace contexts +;;; +;;; Spans are named time intervals with tags and timestamped log events. +;;; Trace IDs and span IDs are random 64-bit integers. +;;; Context propagation uses string maps (e.g. HTTP header alists). + +(library (std span) + (export + ;; Tracer + make-tracer tracer? make-noop-tracer + ;; Span operations + start-span finish-span! span-set-tag! span-log! + ;; Dynamic scoping + with-span current-span + ;; Accessors + span-context span-id trace-id span-duration + ;; Context propagation + inject-context extract-context) + + (import (chezscheme)) + + ;;; ========== ID generation ========== + ;; Random 64-bit integers using Chez's random + (define (gen-id) + ;; Chez random takes a max; use two 32-bit halves + (let ([hi (random (expt 2 31))] + [lo (random (expt 2 31))]) + (+ (* hi (expt 2 31)) lo))) + + ;;; ========== Span context ========== + ;; Carries trace-id and span-id for propagation + (define-record-type %span-context + (fields trace-id span-id)) + + (define (span-context sp) + (make-%span-context (%span-trace-id sp) (%span-id sp))) + + (define (trace-id ctx-or-span) + (cond + [(%span-context? ctx-or-span) (%span-context-trace-id ctx-or-span)] + [(%span? ctx-or-span) (%span-trace-id ctx-or-span)] + [else (error 'trace-id "expected span or span-context" ctx-or-span)])) + + (define (span-id ctx-or-span) + (cond + [(%span-context? ctx-or-span) (%span-context-span-id ctx-or-span)] + [(%span? ctx-or-span) (%span-id ctx-or-span)] + [else (error 'span-id "expected span or span-context" ctx-or-span)])) + + ;;; ========== Span record ========== + ;; name — string + ;; trace-id — integer + ;; id — integer + ;; parent-id — integer or #f + ;; start-time — time object + ;; end-time — mutable, time or #f + ;; tags — mutable alist + ;; logs — mutable list of (time . alist) + ;; finished? — mutable boolean + (define-record-type %span + (fields name trace-id id parent-id start-time + (mutable end-time) + (mutable tags) + (mutable logs) + (mutable finished?)) + (protocol + (lambda (new) + (lambda (name trace-id id parent-id start) + (new name trace-id id parent-id start #f '() '() #f))))) + + ;;; ========== Tracer record ========== + ;; finished-spans — mutable list (for noop: discarded) + (define-record-type %tracer + (fields noop? (mutable finished-spans)) + (protocol + (lambda (new) + (lambda (noop?) + (new noop? '()))))) + + (define (tracer? x) (%tracer? x)) + + (define (make-tracer) (make-%tracer #f)) + (define (make-noop-tracer) (make-%tracer #t)) + + ;;; ========== current-span parameter ========== + (define current-span (make-parameter #f)) + + ;;; ========== start-span ========== + ;; (start-span tracer name) — new root span + ;; (start-span tracer name parent) — child of parent span + (define (start-span tracer name . parent-opt) + (let* ([parent (if (pair? parent-opt) (car parent-opt) (current-span))] + [trace-id (if parent (%span-trace-id parent) (gen-id))] + [parent-id (if parent (%span-id parent) #f)] + [id (gen-id)] + [sp (make-%span name trace-id id parent-id (current-time))]) + sp)) + + ;;; ========== finish-span! ========== + (define (finish-span! tracer sp) + (unless (%span-finished? sp) + (%span-end-time-set! sp (current-time)) + (%span-finished?-set! sp #t) + (unless (%tracer-noop? tracer) + (%tracer-finished-spans-set! tracer + (cons sp (%tracer-finished-spans tracer)))))) + + ;;; ========== span-duration ========== + ;; Returns duration in milliseconds (or #f if not finished) + (define (span-duration sp) + (let ([end (%span-end-time sp)] + [start (%span-start-time sp)]) + (if end + (let ([ds (- (time-second end) (time-second start))] + [dns (- (time-nanosecond end) (time-nanosecond start))]) + (+ (* ds 1000) (div dns 1000000))) + #f))) + + ;;; ========== span-set-tag! ========== + (define (span-set-tag! sp key value) + (%span-tags-set! sp (cons (cons key value) (%span-tags sp)))) + + ;;; ========== span-log! ========== + ;; (span-log! sp key val … ) — append a timestamped event + (define (span-log! sp . kv) + (let ([ts (current-time)] + [fields (parse-kv kv)]) + (%span-logs-set! sp + (cons (cons ts fields) (%span-logs sp))))) + + (define (parse-kv lst) + (let loop ([lst lst] [acc '()]) + (if (null? lst) + (reverse acc) + (if (null? (cdr lst)) + (error 'span-log! "odd number of key/value arguments") + (loop (cddr lst) + (cons (cons (car lst) (cadr lst)) acc)))))) + + ;;; ========== with-span ========== + (define-syntax with-span + (syntax-rules () + [(_ tracer name body ...) + (let* ([parent (current-span)] + [sp (start-span tracer name parent)]) + (parameterize ([current-span sp]) + (let ([result (begin body ...)]) + (finish-span! tracer sp) + result)))] + [(_ tracer name parent body ...) + (let ([sp (start-span tracer name parent)]) + (parameterize ([current-span sp]) + (let ([result (begin body ...)]) + (finish-span! tracer sp) + result)))])) + + ;;; ========== Context propagation ========== + ;; Inject: write trace-id and span-id into a map (alist) + (define (inject-context sp . map-opt) + (let ([m (if (pair? map-opt) (car map-opt) '())]) + (list (cons "X-Trace-Id" (number->string (%span-trace-id sp))) + (cons "X-Span-Id" (number->string (%span-id sp)))))) + + ;; Extract: read a span-context from a map (alist) + (define (extract-context m) + (let ([tid-pair (assoc "X-Trace-Id" m)] + [sid-pair (assoc "X-Span-Id" m)]) + (if (and tid-pair sid-pair) + (make-%span-context + (string->number (cdr tid-pair)) + (string->number (cdr sid-pair))) + #f))) + +) ;; end library new file mode 100644 --- /dev/null +++ b/tests/test-circuit.ss @@ -0,0 +1,223 @@ +#!chezscheme +;;; Tests for (std circuit) -- Circuit breaker pattern + +(import (chezscheme) + (std circuit)) + +(define pass 0) +(define fail 0) + +(define-syntax test + (syntax-rules () + [(_ name expr expected) + (guard (exn [#t (set! fail (+ fail 1)) + (printf "FAIL ~a: ~a~%" name + (if (message-condition? exn) (condition-message exn) exn))]) + (let ([got expr]) + (if (equal? got expected) + (begin (set! pass (+ pass 1)) (printf " ok ~a~%" name)) + (begin (set! fail (+ fail 1)) + (printf "FAIL ~a: got ~s expected ~s~%" name got expected)))))])) + +(printf "--- Phase 3a: Circuit Breaker ---~%~%") + +;;; ======== make-circuit-config ======== + +(let ([cfg (make-circuit-config)]) + (test "default config is a record" + (not (eq? cfg #f)) + #t)) + +(let ([cfg (make-circuit-config 3 1 30)]) + (test "custom config created without error" + (not (eq? cfg #f)) + #t)) + +;;; ======== make-circuit-breaker ======== + +(test "circuit-breaker? true" + (circuit-breaker? (make-circuit-breaker)) + #t) + +(test "circuit-breaker? false" + (circuit-breaker? 'nope) + #f) + +;;; ======== Initial state ======== + +(let ([cb (make-circuit-breaker)]) + (test "initial state is closed" + (circuit-state cb) + 'closed) + + (test "circuit-closed? true initially" + (circuit-closed? cb) + #t) + + (test "circuit-open? false initially" + (circuit-open? cb) + #f) + + (test "circuit-half-open? false initially" + (circuit-half-open? cb) + #f)) + +;;; ======== Successful call ======== + +(let ([cb (make-circuit-breaker)]) + (test "circuit-call returns value" + (circuit-call cb (lambda () 42)) + 42) + + (test "state stays closed after success" + (circuit-state cb) + 'closed)) + +;;; ======== Stats ======== + +(let ([cb (make-circuit-breaker)]) + (circuit-call cb (lambda () 1)) + (circuit-call cb (lambda () 2)) + (let ([stats (circuit-stats cb)]) + (test "stats total-calls" + (cdr (assq 'total-calls stats)) + 2) + (test "stats total-successes" + (cdr (assq 'total-successes stats)) + 2) + (test "stats total-failures" + (cdr (assq 'total-failures stats)) + 0))) + +;;; ======== Failures open the circuit ======== + +(let* ([cfg (make-circuit-config 3 1 60)] ; open after 3 failures + [cb (make-circuit-breaker cfg)]) + + ;; Cause 3 failures + (let fail-it ([n 3]) + (when (> n 0)