Add secmon telemetry client
ober
9d6602818c7373929dca9e65b23fbb9a28765edd
--- a/lib/std/crypto/aead.ss +++ b/lib/std/crypto/aead.ss @@ -19,6 +19,10 @@ (or (try (begin (load-shared-object "libcrypto.so") #t) (catch (e) #f)) (try (begin (load-shared-object "libcrypto.so.3") #t) + (catch (e) #f)) + (try (begin (load-shared-object "/opt/homebrew/opt/openssl@3/lib/libcrypto.dylib") #t) + (catch (e) #f)) + (try (begin (load-shared-object "/usr/local/opt/openssl@3/lib/libcrypto.dylib") #t) (catch (e) #f)))) ;; EVP cipher interface new file mode 100644 --- /dev/null +++ b/lib/std/secmon/telemetry.ss @@ -0,0 +1,335 @@ +#!chezscheme +;;; (std secmon telemetry) -- encrypted mux telemetry client for first-party daemons. + +(library (std secmon telemetry) + (export + MUX-MSG-ENCRYPTED MUX-MSG-TELEMETRY + make-secmon-telemetry + secmon-telemetry? + secmon-telemetry-from-env + secmon-telemetry-enabled? + secmon-telemetry-event + secmon-telemetry-emit! + secmon-telemetry-send! + secmon-transport-key + secmon-mux-frame + secmon-mux-telemetry-frame) + + (import (chezscheme) + (std crypto aead) + (only (std crypto hmac) hmac-sha256) + (only (std net tcp) tcp-connect-binary) + (only (std text json) json-object->string) + (only (jerboa core) def try catch)) + + (def MUX-MSG-ENCRYPTED #x20) + (def MUX-MSG-TELEMETRY #x50) + (def *max-mux-payload* (* 16 1024 1024)) + + (def (make-secmon-telemetry-record host port source local-host daemon transport-key) + (vector 'secmon-telemetry host port source local-host daemon transport-key 0 (make-mutex))) + + (def (secmon-telemetry? v) + (and (vector? v) + (= (vector-length v) 9) + (eq? (vector-ref v 0) 'secmon-telemetry))) + + (def (secmon-telemetry-host v) (vector-ref v 1)) + (def (secmon-telemetry-port v) (vector-ref v 2)) + (def (secmon-telemetry-source v) (vector-ref v 3)) + (def (secmon-telemetry-local-host v) (vector-ref v 4)) + (def (secmon-telemetry-daemon v) (vector-ref v 5)) + (def (secmon-telemetry-transport-key v) (vector-ref v 6)) + (def (secmon-telemetry-seq v) (vector-ref v 7)) + (def (secmon-telemetry-lock v) (vector-ref v 8)) + (def (secmon-telemetry-seq-set! v seq) (vector-set! v 7 seq)) + + (def (u8? v) + (and (integer? v) (>= v 0) (<= v 255))) + + (def (nonempty-string? v) + (and (string? v) (not (string=? v "")))) + + (def (bytevector-copy* bv start end) + (let ((out (make-bytevector (- end start) 0))) + (bytevector-copy! bv start out 0 (- end start)) + out)) + + (def (read-file-string path) + (call-with-input-file path + (lambda (in) + (let loop ((chars '())) + (let ((ch (read-char in))) + (if (eof-object? ch) + (list->string (reverse chars)) + (loop (cons ch chars)))))))) + + (def (string-trim-ascii s) + (let* ((n (string-length s)) + (start (let loop ((i 0)) + (if (and (< i n) + (let ((c (string-ref s i))) + (or (char=? c #\space) + (char=? c #\tab) + (char=? c #\newline) + (char=? c #\return)))) + (loop (+ i 1)) + i))) + (end (let loop ((i (- n 1))) + (if (and (>= i start) + (let ((c (string-ref s i))) + (or (char=? c #\space) + (char=? c #\tab) + (char=? c #\newline) + (char=? c #\return)))) + (loop (- i 1)) + (+ i 1))))) + (substring s start end))) + + (def (read-file-trimmed path) + (string-trim-ascii (read-file-string path))) + + (def (string-prefix? prefix s) + (let ((pn (string-length prefix)) + (sn (string-length s))) + (and (<= pn sn) + (string=? prefix (substring s 0 pn))))) + + (def (path-like-key? v) + (and (string? v) + (< (string-length v) 128) + (or (string-prefix? "/" v) + (string-prefix? "." v) + (file-exists? v)))) + + (def (resolve-key-value v) + (if (path-like-key? v) + (try (read-file-trimmed v) (catch (e) v)) + v)) + + (def (lookup-env names) + (let loop ((xs names)) + (cond + ((null? xs) #f) + ((getenv (car xs)) => (lambda (v) v)) + (else (loop (cdr xs)))))) + + (def (load-psk-hex) + (cond + ((lookup-env '("SECMON_PSK" "PSK")) => resolve-key-value) + ((lookup-env '("SECMON_PSK_FILE" "PSK_FILE")) + => (lambda (p) + (try (read-file-trimmed p) (catch (e) #f)))) + (else #f))) + + (def (hex-val c) + (cond + ((and (char>=? c #\0) (char<=? c #\9)) + (- (char->integer c) (char->integer #\0))) + ((and (char>=? c #\a) (char<=? c #\f)) + (+ 10 (- (char->integer c) (char->integer #\a)))) + ((and (char>=? c #\A) (char<=? c #\F)) + (+ 10 (- (char->integer c) (char->integer #\A)))) + (else #f))) + + (def (hex-decode-checked s) + (and (string? s) + (= (modulo (string-length s) 2) 0) + (let* ((n (/ (string-length s) 2)) + (out (make-bytevector n 0))) + (let loop ((i 0)) + (cond + ((= i n) out) + (else + (let ((hi (hex-val (string-ref s (* i 2)))) + (lo (hex-val (string-ref s (+ (* i 2) 1))))) + (and hi lo + (begin + (bytevector-u8-set! out i (+ (* hi 16) lo)) + (loop (+ i 1))))))))))) + + (def (decode-psk-32 hex) + (let ((psk (hex-decode-checked (string-trim-ascii hex)))) + (and (bytevector? psk) + (= (bytevector-length psk) 32) + psk))) + + (def (hkdf-extract salt ikm) + (hmac-sha256 + (if (and (bytevector? salt) (> (bytevector-length salt) 0)) + salt + (make-bytevector 32 0)) + ikm)) + + (def (hkdf-expand-32 prk info) + (hmac-sha256 prk (bytevector-append info (u8-list->bytevector '(1))))) + + (def (secmon-transport-key psk) + (hkdf-expand-32 + (hkdf-extract (make-bytevector 0) psk) + (string->utf8 "secmon-psk-transport-v1"))) + + (def (secmon-mux-frame type payload) + (unless (u8? type) + (error 'secmon-mux-frame "message type must be a byte" type)) + (let* ((data (if (string? payload) (string->utf8 payload) payload)) + (len (bytevector-length data)) + (frame (make-bytevector (+ 5 len) 0))) + (when (> len *max-mux-payload*) + (error 'secmon-mux-frame "payload too large" len)) + (bytevector-u8-set! frame 0 type) + (bytevector-u8-set! frame 1 (bitwise-and (bitwise-arithmetic-shift-right len 24) #xff)) + (bytevector-u8-set! frame 2 (bitwise-and (bitwise-arithmetic-shift-right len 16) #xff)) + (bytevector-u8-set! frame 3 (bitwise-and (bitwise-arithmetic-shift-right len 8) #xff)) + (bytevector-u8-set! frame 4 (bitwise-and len #xff)) + (bytevector-copy! data 0 frame 5 len) + frame)) + + (def (secmon-mux-telemetry-frame transport-key event) + (let* ((plain (secmon-mux-frame + MUX-MSG-TELEMETRY + (string->utf8 (json-object->string event))))) + (secmon-mux-frame + MUX-MSG-ENCRYPTED + (aead-encrypt transport-key plain (make-bytevector 0))))) + + (def (last-colon s) + (let loop ((i (- (string-length s) 1))) + (cond + ((< i 0) #f) + ((char=? (string-ref s i) #\:) i) + (else (loop (- i 1)))))) + + (def (parse-host-port s default-port) + (let ((p (and (string? s) (last-colon s)))) + (cond + ((not p) (cons s default-port)) + (else + (let ((host (substring s 0 p)) + (port (string->number (substring s (+ p 1) (string-length s))))) + (and port (>= port 1) (<= port 65535) + (cons (if (string=? host "") "127.0.0.1" host) port))))))) + + (def (default-local-host) + (or (getenv "SECMON_TELEMETRY_HOST") + (getenv "HOSTNAME") + (getenv "COMPUTERNAME") + "unknown")) + + (def (default-source daemon host) + (string-append daemon "@" host)) + + (def (make-secmon-telemetry host port source local-host daemon transport-key) + (make-secmon-telemetry-record host port source local-host daemon transport-key)) + + (def (secmon-telemetry-from-env daemon) + (let ((addr (lookup-env '("SECMON_TELEMETRY_ADDR" "SECMON_TELEMETRY_CONNECT"))) + (psk-hex (load-psk-hex))) + (and addr psk-hex + (let ((hp (parse-host-port addr 31338)) + (psk (decode-psk-32 psk-hex))) + (and hp psk + (let* ((local-host (default-local-host)) + (source (or (getenv "SECMON_TELEMETRY_SOURCE") + (default-source daemon local-host)))) + (make-secmon-telemetry + (car hp) + (cdr hp) + source + local-host + daemon + (secmon-transport-key psk)))))))) + + (def (secmon-telemetry-enabled? telemetry) + (and (secmon-telemetry? telemetry) + (bytevector? (secmon-telemetry-transport-key telemetry)))) + + (def (next-seq! telemetry) + (dynamic-wind + (lambda () (mutex-acquire (secmon-telemetry-lock telemetry))) + (lambda () + (let ((next (+ (secmon-telemetry-seq telemetry) 1))) + (secmon-telemetry-seq-set! telemetry next) + next)) + (lambda () (mutex-release (secmon-telemetry-lock telemetry))))) + + (def (current-time-ms) + (let ((t (current-time))) + (+ (* (time-second t) 1000) + (quotient (time-nanosecond t) 1000000)))) + + (def (hash . kvs) + (let ((h (make-hashtable equal-hash equal?))) + (let loop ((xs kvs)) + (unless (or (null? xs) (null? (cdr xs))) + (hashtable-set! h (car xs) (cadr xs)) + (loop (cddr xs)))) + h)) + + (def (copy-fields! dst fields) + (cond + ((hashtable? fields) + (let-values (((keys vals) (hashtable-entries fields))) + (let ((n (vector-length keys))) + (let loop ((i 0)) + (when (< i n) + (hashtable-set! dst (vector-ref keys i) (vector-ref vals i)) + (loop (+ i 1))))))) + ((list? fields) + (let loop ((xs fields)) + (cond + ((null? xs) (void)) + ((and (pair? (car xs)) (string? (caar xs))) + (hashtable-set! dst (caar xs) (cdar xs)) + (loop (cdr xs))) + ((and (string? (car xs)) (pair? (cdr xs))) + (hashtable-set! dst (car xs) (cadr xs)) + (loop (cddr xs))) + (else (loop (cdr xs)))))))) + + (def (secmon-telemetry-event telemetry action severity fields) + (let ((data (hash "daemon" (secmon-telemetry-daemon telemetry) + "action" action)) + (event (hash "event_type" "daemon_telemetry" + "host" (secmon-telemetry-local-host telemetry) + "timestamp_ms" (current-time-ms) + "severity" severity + "process_name" (secmon-telemetry-daemon telemetry) + "source" (secmon-telemetry-source telemetry) + "seq" (next-seq! telemetry)))) + (copy-fields! data fields) + (hashtable-set! event "data" data) + event)) + + (def (close-port/quiet port) + (try (close-port port) (catch (e) #f))) + + (def (send-frame! telemetry frame) + (let-values (((in out) + (tcp-connect-binary + (secmon-telemetry-host telemetry) + (secmon-telemetry-port telemetry)))) + (dynamic-wind + (lambda () (void)) + (lambda () + (put-bytevector out frame) + (flush-output-port out)) + (lambda () + (close-port/quiet out) + (close-port/quiet in))))) + + (def (secmon-telemetry-send! telemetry event) + (when (secmon-telemetry-enabled? telemetry) + (send-frame! + telemetry + (secmon-mux-telemetry-frame + (secmon-telemetry-transport-key telemetry) + event)))) + + (def (secmon-telemetry-emit! telemetry action severity . fields) + (when (secmon-telemetry-enabled? telemetry) + (let ((event (secmon-telemetry-event telemetry action severity fields))) + (fork-thread + (lambda () + (try (secmon-telemetry-send! telemetry event) + (catch (e) #f)))))))) new file mode 100644 --- /dev/null +++ b/tests/test-secmon-telemetry.ss @@ -0,0 +1,87 @@ +#!chezscheme +;;; test-secmon-telemetry.ss -- encrypted mux telemetry client checks. + +(import (chezscheme) + (std secmon telemetry)) + +(define pass-count 0) +(define fail-count 0) + +(define-syntax check + (syntax-rules (=>) + [(_ expr => expected) + (let ([result expr] + [exp expected]) + (if (equal? result exp) + (set! pass-count (+ pass-count 1)) + (begin + (set! fail-count (+ fail-count 1)) + (display "FAIL: ") + (write 'expr) + (display " => ") + (write result) + (display " expected ") + (write exp) + (newline))))])) + +(define (bytevector->hex bv) + (define digits "0123456789abcdef") + (let* ([n (bytevector-length bv)] + [out (make-string (* n 2) #\0)]) + (let loop ([i 0]) + (when (< i n) + (let ([b (bytevector-u8-ref bv i)]) + (string-set! out (* i 2) + (string-ref digits + (bitwise-and + (bitwise-arithmetic-shift-right b 4) + #xf))) + (string-set! out (+ (* i 2) 1) + (string-ref digits (bitwise-and b #xf))) + (loop (+ i 1))))) + out)) + +(define psk (make-bytevector 32 #x42)) +(define transport-key (secmon-transport-key psk)) + +(check (bytevector->hex transport-key) + => "ba1cc1ebdc48f9f07fa555807dae410a13093ed5d6375919ae3766cf7d748091") + +(let ([frame (secmon-mux-frame MUX-MSG-TELEMETRY (string->utf8 "abc"))]) + (check (bytevector->u8-list frame) => '(80 0 0 0 3 97 98 99))) + +(let* ([telemetry (make-secmon-telemetry + "127.0.0.1" + 31338 + "unit@host" + "host" + "unitd" + transport-key)] + [event (secmon-telemetry-event + telemetry + "probe" + "low" + '("remote_ip" "203.0.113.4" + "target" "/tmp/probe"))] + [data (hashtable-ref event "data" #f)]) + (check (secmon-telemetry-enabled? telemetry) => #t) + (check (hashtable-ref event "event_type" #f) => "daemon_telemetry") + (check (hashtable-ref event "source" #f) => "unit@host") + (check (hashtable-ref event "seq" #f) => 1) + (check (hashtable-ref data "daemon" #f) => "unitd") + (check (hashtable-ref data "action" #f) => "probe") + (check (hashtable-ref data "remote_ip" #f) => "203.0.113.4") + (let ([sealed (secmon-mux-telemetry-frame transport-key event)]) + (check (bytevector-u8-ref sealed 0) => MUX-MSG-ENCRYPTED) + (check (> (bytevector-length sealed) 5) => #t))) + +(display " secmon-telemetry: ") +(display pass-count) +(display " passed") +(when (> fail-count 0) + (display ", ") + (display fail-count) + (display " failed")) +(newline) +(when (> fail-count 0) + (exit 1))