std/os/aproc: async subprocess; sandbox/uuid TC-mutex + seed fixes
ober
821fc9abb5339697f6fa902cf385b1d239f0e508
--- a/lib/std/misc/uuid.sls +++ b/lib/std/misc/uuid.sls @@ -8,6 +8,20 @@ (import (chezscheme)) + ;; Chez's random-seed is initialised to a fixed value at startup, so + ;; uuid-string would emit the same sequence across every fresh process + ;; (claude/gemini's --session-id would then collide between runs). + ;; Seed once from the wall clock so each process starts with its own + ;; PRNG state. random-seed expects an exact integer in [1, 2^32-1]. + (define _uuid-seed-once + (let ((t (current-time))) + (random-seed + (let ((mixed (bitwise-xor + (time-nanosecond t) + (bitwise-arithmetic-shift-left + (time-second t) 16)))) + (max 1 (mod (bitwise-and mixed #xFFFFFFFF) 4294967295)))))) + (define (uuid-string) ;; Generate a UUID v4 string (let ((bytes (make-bytevector 16))) new file mode 100644 --- /dev/null +++ b/lib/std/os/aproc.sls @@ -0,0 +1,339 @@ +#!chezscheme +;;; (std os aproc) -- Asynchronous subprocess execution +;;; +;;; Run external commands without freezing other Scheme threads. +;;; +;;; Background: Chez's built-in (system cmd) and (open-process-ports ...)'s +;;; subsequent I/O acquire the TC mutex, which means while one thread is +;;; parked in those calls every other green thread in the process is +;;; suspended. TUIs, watchdogs, streaming chat loops, debug REPLs etc. all +;;; freeze for the lifetime of the subprocess. This library exposes a +;;; subprocess facility whose blocking syscalls are declared __collect_safe, +;;; so the TC mutex is released while the kernel does the work — everything +;;; else keeps running. +;;; +;;; Quick usage: +;;; (aproc-run "echo hello") ; => "hello\n" +;;; (aproc-run/status "false") ; => (values "" "" 1) +;;; (aproc-system "make -j8 all") ; => exit code (non-blocking) +;;; +;;; Streaming: +;;; (let ((h (aproc-spawn "tail -F log"))) +;;; (let loop () +;;; (let ((chunk (aproc-read-stdout h))) +;;; (if (eof-object? chunk) +;;; (aproc-wait h) +;;; (begin (display (utf8->string chunk)) (loop)))))) + +(library (std os aproc) + (export + ;; Low-level handle API + aproc-spawn + aproc-handle? + aproc-pid + aproc-stdin-fd + aproc-stdout-fd + aproc-stderr-fd + aproc-exit-code + aproc-read + aproc-read-stdout + aproc-read-stderr + aproc-write + aproc-close-stdin! + aproc-close! + aproc-wait + aproc-poll + aproc-kill + aproc-collect + + ;; High-level convenience + aproc-run + aproc-run/status + aproc-system) + + (import (chezscheme)) + + ;; Ensure libc symbols are visible. (load-shared-object #f) searches the + ;; running image, which works for both dynamic builds and static binaries. + (define _libc-loaded + (or (guard (e [#t #f]) (load-shared-object #f)) + (guard (e [#t #f]) (load-shared-object "libc.so.7")) + (guard (e [#t #f]) (load-shared-object "libc.so.6")) + (guard (e [#t #f]) (load-shared-object "libc.so")) + (guard (e [#t #f]) (load-shared-object "libc.dylib")))) + + ;; ========== FFI ========== + ;; All long-running calls are __collect_safe so other green threads keep + ;; running while we're parked in the kernel. Without __collect_safe these + ;; calls would pin the TC mutex for their entire duration. + (define c-read + (foreign-procedure __collect_safe "read" + (int u8* unsigned-int) int)) + (define c-write + (foreign-procedure __collect_safe "write" + (int u8* unsigned-int) int)) + (define c-waitpid + (foreign-procedure __collect_safe "waitpid" + (int u8* int) int)) + ;; system(3) takes a NUL-terminated C string. __collect_safe forbids + ;; the Scheme `string` foreign type (the string could be relocated by + ;; GC during the call), so we pass a bytevector copy with an explicit + ;; trailing NUL via the u8* type, which pins the buffer for the call. + (define c-system-safe + (foreign-procedure __collect_safe "system" (u8*) int)) + + ;; Fast / non-blocking calls — TC mutex held is fine. + (define c-kill (foreign-procedure "kill" (int int) int)) + (define c-close (foreign-procedure "close" (int) int)) + (define c-dup (foreign-procedure "dup" (int) int)) + + (define WNOHANG 1) + (define SIGTERM 15) + (define SIGKILL 9) + + ;; ========== Handle ========== + ;; We keep the ports alive in the record so the GC doesn't close their + ;; underlying fds while we're still reading from them via raw c-read. + (define-record-type aproc-rec + (fields + (immutable pid) + (immutable stdin-port) + (immutable stdout-port) + (immutable stderr-port) + (immutable stdin-fd) + (immutable stdout-fd) + (immutable stderr-fd) + (mutable exit-code)) + (sealed #t)) + + (define (aproc-handle? x) (aproc-rec? x)) + (define aproc-pid aproc-rec-pid) + (define aproc-stdin-fd aproc-rec-stdin-fd) + (define aproc-stdout-fd aproc-rec-stdout-fd) + (define aproc-stderr-fd aproc-rec-stderr-fd) + (define aproc-exit-code aproc-rec-exit-code) + + ;; ========== spawn ========== + ;; aproc-spawn: launch CMD via /bin/sh -c and return a handle. + ;; The Chez ports returned by open-process-ports are retained inside the + ;; handle so their fds stay open; we never use them for I/O (which would + ;; pin the TC mutex) — we read/write through the bare fds via c-read / + ;; c-write declared __collect_safe. + (define (aproc-spawn cmd) + (let-values ([(stdin-p stdout-p stderr-p pid) + (open-process-ports cmd (buffer-mode none) #f)]) + (make-aproc-rec + pid + stdin-p stdout-p stderr-p + (port-file-descriptor stdin-p) + (port-file-descriptor stdout-p) + (port-file-descriptor stderr-p) + #f))) + + ;; ========== I/O ========== + ;; aproc-read: read up to COUNT bytes from FD. Blocks (in the kernel, + ;; with TC mutex released) until data arrives or EOF. + ;; Returns a bytevector with the data, or #!eof on end-of-stream. + (define aproc-read + (case-lambda + [(h fd) (aproc-read h fd 4096)] + [(h fd count) + (let* ((buf (make-bytevector count)) + (n (c-read fd buf count))) + (cond + ((= n 0) (eof-object)) + ((< n 0) (error 'aproc-read "read(2) failed" fd)) + ((= n count) buf) + (else + (let ((r (make-bytevector n))) + (bytevector-copy! buf 0 r 0 n) + r))))])) + + (define (aproc-read-stdout h . maybe-count) + (apply aproc-read h (aproc-rec-stdout-fd h) maybe-count)) + + (define (aproc-read-stderr h . maybe-count) + (apply aproc-read h (aproc-rec-stderr-fd h) maybe-count)) + + ;; aproc-write: write BV to the subprocess's stdin. Returns bytes written. + ;; May write fewer bytes than requested (short write) — caller handles + ;; retries. + (define (aproc-write h bv) + (let ((n (c-write (aproc-rec-stdin-fd h) bv (bytevector-length bv)))) + (when (< n 0) + (error 'aproc-write "write(2) failed")) + n)) + + ;; aproc-close-stdin!: close the subprocess's stdin (sends EOF). + (define (aproc-close-stdin! h) + (let ((p (aproc-rec-stdin-port h))) + (when p + (guard (e [#t (void)]) (close-port p))))) + + ;; ========== wait / poll ========== + ;; aproc-wait: block until the subprocess exits, return its exit code. + ;; __collect_safe waitpid so other green threads keep running. + (define (aproc-wait h) + (cond + ((aproc-rec-exit-code h) => (lambda (x) x)) + (else + (let ((status-buf (make-bytevector 4 0))) + (let loop () + (let ((rc (c-waitpid (aproc-rec-pid h) status-buf 0))) + (cond + ((< rc 0) + ;; Most likely EINTR; in practice this is extremely rare + ;; with __collect_safe waitpid, but we retry rather than + ;; raise on it. + (loop)) + (else + (let* ((raw (bytevector-s32-native-ref status-buf 0)) + (code (waitpid-status->exit-code raw))) + (aproc-rec-exit-code-set! h code) + code))))))))) + + ;; aproc-poll: non-blocking check. Returns exit code if exited, else #f. + (define (aproc-poll h) + (cond + ((aproc-rec-exit-code h) => (lambda (x) x)) + (else + (let* ((status-buf (make-bytevector 4 0)) + (rc (c-waitpid (aproc-rec-pid h) status-buf WNOHANG))) + (cond + ((< rc 0) #f) + ((= rc 0) #f) + (else + (let* ((raw (bytevector-s32-native-ref status-buf 0)) + (code (waitpid-status->exit-code raw))) + (aproc-rec-exit-code-set! h code) + code))))))) + + ;; aproc-kill: send SIG (default SIGTERM) to the subprocess. + (define aproc-kill + (case-lambda + [(h) (aproc-kill h SIGTERM)] + [(h sig) + (c-kill (aproc-rec-pid h) sig) + (void)])) + + ;; aproc-close!: close all stdio ports + reap if not already reaped. + ;; Safe to call multiple times. + (define (aproc-close! h) + (for-each + (lambda (p) + (when p (guard (e [#t (void)]) (close-port p)))) + (list (aproc-rec-stdin-port h) + (aproc-rec-stdout-port h) + (aproc-rec-stderr-port h))) + (unless (aproc-rec-exit-code h) + (guard (e [#t (void)]) (aproc-wait h)))) + + ;; ========== high-level: collect ========== + ;; aproc-collect: drain stdout + stderr, wait for exit, return all three. + ;; Returns (values stdout-string stderr-string exit-code). + (define (aproc-collect h) + (let* ((out (drain-fd (aproc-rec-stdout-fd h))) + (err (drain-fd (aproc-rec-stderr-fd h))) + (code (aproc-wait h))) + (aproc-close! h) + (values (utf8->string out) + (utf8->string err) + code))) + + ;; ========== top-level convenience ========== + ;; aproc-run/status: run CMD via /bin/sh -c, return stdout/stderr/exit-code. + ;; Optional DIR is cd'd into before running. + (define aproc-run/status + (case-lambda + [(cmd) (aproc-run/status cmd #f)] + [(cmd dir) + (let* ((full (if dir + (string-append "cd " (sh-quote dir) " && " cmd) + cmd)) + (h (aproc-spawn full))) + (aproc-close-stdin! h) + (aproc-collect h))])) + + ;; aproc-run: return stdout (raises on nonzero exit unless check?=#f). + (define aproc-run + (case-lambda + [(cmd) (aproc-run cmd #f #t)] + [(cmd dir) (aproc-run cmd dir #t)] + [(cmd dir check?) + (let-values ([(out err code) (aproc-run/status cmd dir)]) + (when (and check? (not (= code 0))) + (error 'aproc-run + (string-append "command failed (exit " + (number->string code) "): " cmd + (if (string=? err "") "" (string-append "\n" err))))) + out)])) + + ;; aproc-system: run CMD via libc system(3) declared __collect_safe. + ;; Does not capture output (stdout/stderr go to the parent's terminal). + ;; Use when you just need to run a shell command without freezing the + ;; scheduler — much cheaper than aproc-spawn when you don't need output. + ;; Returns the exit code (or 128+signal if killed by signal). + (define (aproc-system cmd) + (let ((rc (c-system-safe (string->cstring cmd)))) + (waitpid-status->exit-code rc))) + + ;; Copy a Scheme string into a NUL-terminated bytevector for FFI. + (define (string->cstring s) + (let* ((bv (string->utf8 s)) + (n (bytevector-length bv)) + (r (make-bytevector (+ n 1) 0))) + (bytevector-copy! bv 0 r 0 n) + r)) + + ;; ========== helpers ========== + (define (drain-fd fd) + (let loop ((chunks '()) (total 0)) + (let* ((buf (make-bytevector 4096)) + (n (c-read fd buf 4096))) + (cond + ((< n 0) (error 'drain-fd "read(2) failed" fd)) + ((= n 0) (concat-chunks (reverse chunks) total)) + (else + (let ((chunk (if (= n 4096) + buf + (let ((r (make-bytevector n))) + (bytevector-copy! buf 0 r 0 n) + r)))) + (loop (cons chunk chunks) (+ total n)))))))) + + (define (concat-chunks chunks total) + (let ((r (make-bytevector total))) + (let lp ((cs chunks) (off 0)) + (cond + ((null? cs) r) + (else + (let* ((c (car cs)) + (cl (bytevector-length c))) + (bytevector-copy! c 0 r off cl) + (lp (cdr cs) (+ off cl)))))))) + + ;; POSIX waitpid status decoding: + ;; low 7 bits = terminating signal (0 if exited normally) + ;; bits 8-15 = exit status when low 7 bits == 0 + (define (waitpid-status->exit-code st) + (cond + ((< st 0) -1) + ((= (bitwise-and st #x7f) 0) + (bitwise-and (bitwise-arithmetic-shift-right st 8) #xff)) + (else + (+ 128 (bitwise-and st #x7f))))) + + (define (sh-quote s) + (string-append "'" (sh-escape s) "'")) + + (define (sh-escape s) + (let loop ((i 0) (acc '())) + (cond + ((= i (string-length s)) + (apply string-append (reverse acc))) + ((char=? (string-ref s i) #\') + (loop (+ i 1) (cons "'\"'\"'" acc))) + (else + (loop (+ i 1) (cons (string (string-ref s i)) acc)))))) + +) ;; end library --- a/lib/std/os/sandbox.sls +++ b/lib/std/os/sandbox.sls @@ -72,7 +72,12 @@ ;; ========== FFI ========== (define c-fork (foreign-procedure "fork" () int)) - (define c-waitpid (foreign-procedure "waitpid" (int void* int) int)) + ;; waitpid is __collect_safe so the parent releases Chez's TC mutex + ;; while parked in the kernel. Without that, sandbox-run/wait-for-child + ;; freezes every other green thread (TUI, watchdogs, streaming loops) + ;; for the lifetime of the sandboxed child. + (define c-waitpid + (foreign-procedure __collect_safe "waitpid" (int void* int) int)) (define c-exit (foreign-procedure "_exit" (int) void)) ;; ========== Landlock FFI (Linux) ==========