Fix 8 architectural issues: sandbox escape, injection, thread leaks, backpressure
ober
ae5c2480091cfd74bf15626e03361f7b2a63e011
--- a/lib/jerboa/core.sls +++ b/lib/jerboa/core.sls @@ -358,19 +358,47 @@ (define tid (record-type-descriptor hidden-name)) (define acc iacc) ... (define mut imut) ...)))))] - ;; Accept and ignore trailing keyword-value options (transparent:, opaque:, etc.) + ;; Keyword options: warn about unsupported ones, handle what we can. + ;; Supported: transparent: #t (makes record non-opaque, visible to inspector) + ;; Unsupported: final:, opaque:, print: etc. — raise error instead of silently dropping. [(_ name (field ...) kw val rest ...) - #'(defstruct name (field ...))] + (let ([key (syntax->datum #'kw)]) + (unless (memq key '(transparent: final: opaque: print: equal: constructor:)) + (syntax-violation 'defstruct + (format "unknown keyword option: ~a" key) #'kw)) + (when (memq key '(final: print: equal: constructor:)) + (syntax-violation 'defstruct + (format "keyword ~a is not supported in Jerboa defstruct (Chez R6RS limitation)" key) + #'kw)) + ;; transparent: and opaque: are accepted — Chez records don't use + ;; hidden names in transparent mode (but our hidden-name approach + ;; already makes fields accessible via accessors, so this is informational). + #'(defstruct name (field ...)))] [(_ (name parent) (field ...) kw val rest ...) - #'(defstruct (name parent) (field ...))]))) + (let ([key (syntax->datum #'kw)]) + (unless (memq key '(transparent: final: opaque: print: equal: constructor:)) + (syntax-violation 'defstruct + (format "unknown keyword option: ~a" key) #'kw)) + (when (memq key '(final: print: equal: constructor:)) + (syntax-violation 'defstruct + (format "keyword ~a is not supported in Jerboa defstruct (Chez R6RS limitation)" key) + #'kw)) + #'(defstruct (name parent) (field ...)))])) ;;;; ---- DEFCLASS ---- + ;; NOTE: defclass in Jerboa maps to defstruct (single inheritance via Chez records). + ;; Gerbil's defclass supports multiple inheritance and mixins — these are NOT supported. + ;; Using multiple parents will raise an error. (define-syntax defclass (lambda (stx) (syntax-case stx () [(_ (name parent) (field ...) rest ...) #'(defstruct (name parent) (field ...))] + [(_ (name parent1 parent2 . more-parents) (field ...) rest ...) + (syntax-violation 'defclass + "multiple inheritance is not supported in Jerboa (use single parent only)" + stx)] [(_ name (field ...) rest ...) #'(defstruct name (field ...))]))) --- a/lib/std/actor/core.sls +++ b/lib/std/actor/core.sls @@ -260,10 +260,18 @@ (let ([parent (current-actor)] [child (spawn-actor-impl behavior name)]) (when parent - (actor-ref-links-set! parent (cons child (actor-ref-links parent))) - (actor-ref-links-set! child (cons parent (actor-ref-links child)))) + ;; Synchronize link list modifications under the sched-mutex + ;; to prevent concurrent link corruption. + (with-mutex (actor-ref-sched-mutex parent) + (actor-ref-links-set! parent (cons child (actor-ref-links parent)))) + (with-mutex (actor-ref-sched-mutex child) + (actor-ref-links-set! child (cons parent (actor-ref-links child))))) child)) + ;; Maximum mailbox size. When exceeded, send logs a warning to stderr. + ;; Set to #f to disable the warning. Default: 10000. + (define *actor-max-mailbox-size* (make-parameter 10000)) + (define (send actor msg) (cond [(not (actor-ref? actor)) @@ -276,6 +284,17 @@ (error 'send "remote send not configured; call set-remote-send-handler!" actor)))] ;; Local, alive [(actor-alive? actor) + ;; Backpressure warning: log if mailbox is growing too large + (let ([max-size (*actor-max-mailbox-size*)]) + (when max-size + (let ([mbox-size (mpsc-length (actor-ref-mailbox actor))]) + (when (and (fx> mbox-size max-size) + (fx= (fxmod mbox-size max-size) 0)) + (fprintf (current-error-port) + "WARNING: actor #~a (~a) mailbox at ~a messages (exceeds ~a)~%" + (actor-ref-id actor) + (or (actor-ref-name actor) "?") + mbox-size max-size))))) (mpsc-enqueue! (actor-ref-mailbox actor) msg) (with-mutex (actor-ref-sched-mutex actor) (when (eq? (actor-ref-state actor) 'idle) --- a/lib/std/concur/structured.sls +++ b/lib/std/concur/structured.sls @@ -67,24 +67,38 @@ (let ([scope (*current-scope*)]) (unless scope (error 'scope-spawn "not inside with-task-scope")) - (let* ([t #f] + ;; Create the task record BEFORE forking the thread, so the thread + ;; always has a valid task reference. Use a gate (mutex+cond) to + ;; ensure the thread doesn't start work until the task is ready. + (let* ([gate-mutex (make-mutex)] + [gate-cond (make-condition)] + [gate-open? #f] + [t #f] [thread (fork-thread (lambda () + ;; Wait for task record to be initialized + (with-mutex gate-mutex + (let loop () + (unless gate-open? + (condition-wait gate-cond gate-mutex) + (loop)))) (guard (exn - [#t (when t - (task-error-set! t exn) - (task-done?-set! t #t) - (with-mutex (task-mutex t) - (condition-broadcast (task-condvar t))))]) + [#t (task-error-set! t exn) + (task-done?-set! t #t) + (with-mutex (task-mutex t) + (condition-broadcast (task-condvar t)))]) (let ([result (thunk)]) - (when t - (task-result-set! t result) - (task-done?-set! t #t) - (with-mutex (task-mutex t) - (condition-broadcast (task-condvar t))))))))]) + (task-result-set! t result) + (task-done?-set! t #t) + (with-mutex (task-mutex t) + (condition-broadcast (task-condvar t)))))))]) (set! t (make-task name thread)) (task-done?-set! t #f) (scope-add-task! scope t) + ;; Open the gate — thread can now proceed + (with-mutex gate-mutex + (set! gate-open? #t) + (condition-broadcast gate-cond)) t))) ;; ========== Await ========== @@ -101,7 +115,11 @@ (task-result task))) (define (task-cancel task) - ;; Mark as done with a cancellation error + ;; Mark as done with a cancellation error. + ;; NOTE: This does NOT stop the underlying thread — Chez Scheme has no + ;; safe thread interruption. The thread continues executing but its result + ;; is ignored. Callers should use cooperative cancellation (check a flag + ;; periodically) for long-running tasks. (unless (task-done? task) (task-error-set! task (make-message-condition "task cancelled")) (task-done?-set! task #t) @@ -114,10 +132,23 @@ (for-each task-cancel (task-scope-tasks scope))) (define (await-all-tasks! scope) + ;; Wait for all tasks, but don't block forever on cancelled tasks + ;; whose threads are still running. Use a 5-second timeout per + ;; cancelled task to prevent with-task-scope from hanging. (for-each (lambda (t) (guard (exn [#t (void)]) ;; ignore errors from cancelled tasks - (task-await t))) + (if (task-done? t) + ;; Already done — just retrieve (may re-raise error) + (task-await t) + ;; Not done — wait with timeout + (let loop ([attempts 0]) + (with-mutex (task-mutex t) + (unless (task-done? t) + (condition-wait (task-condvar t) (task-mutex t) + (make-time 'time-duration 0 5)))) ;; 5 second timeout + (unless (or (task-done? t) (> attempts 0)) + (loop (+ attempts 1))))))) (task-scope-tasks scope))) (define (with-task-scope thunk) --- a/lib/std/misc/channel.sls +++ b/lib/std/misc/channel.sls @@ -212,16 +212,18 @@ (loop (cdr chs) (cdr hs))))))) ;; Blocking select with optional timeout - ;; Strategy: shared condition variable that all channels signal + ;; Strategy: shared condition + stop flag so watcher threads terminate cleanly (define (channel-select-wait channels handlers timeout-secs timeout-thunk) ;; First, try non-blocking (let try-loop ([chs channels] [hs handlers]) (if (null? chs) ;; None ready — block (let ([shared-cond (make-condition)] - [shared-mutex (make-mutex)]) + [shared-mutex (make-mutex)] + [stop-box (box #f)]) ;; signal watchers to stop ;; Install watchers: for each channel, spawn a thread that waits - ;; and signals the shared condition when data arrives + ;; and signals the shared condition when data arrives. + ;; Watchers check stop-box to terminate cleanly. (let ([watchers (map (lambda (ch) (fork-thread @@ -229,8 +231,9 @@ (with-mutex (channel-mutex ch) (let loop () (cond + ;; Stop flag set — another watcher found data, exit + [(unbox stop-box) (void)] [(fx> (channel-count ch) 0) - ;; Data available — signal main (mutex-acquire shared-mutex) (condition-signal shared-cond) (mutex-release shared-mutex)] @@ -239,26 +242,34 @@ (condition-signal shared-cond) (mutex-release shared-mutex)] [else + ;; Use timed wait so we can check stop-box periodically (condition-wait (channel-not-empty ch) - (channel-mutex ch)) + (channel-mutex ch) + (make-time 'time-duration 100000000 0)) ;; 100ms (loop)])))))) channels)]) ;; Wait on shared condition (mutex-acquire shared-mutex) (if timeout-secs - (let ([ns (exact (floor (* timeout-secs 1000000000)))] - [s (exact (floor timeout-secs))]) - (let ([ns-part (exact (floor (* (- timeout-secs s) 1000000000)))]) - (condition-wait shared-cond shared-mutex - (make-time 'time-duration ns-part s)))) + (let ([s (exact (floor timeout-secs))] + [ns-part (exact (floor (* (- timeout-secs (floor timeout-secs)) 1000000000)))]) + (condition-wait shared-cond shared-mutex + (make-time 'time-duration ns-part s))) (condition-wait shared-cond shared-mutex)) (mutex-release shared-mutex) + ;; Signal all watchers to stop + (set-box! stop-box #t) + ;; Wake all channel conditions so watchers can see the stop flag + (for-each (lambda (ch) + (with-mutex (channel-mutex ch) + (condition-broadcast (channel-not-empty ch)))) + channels) ;; Try again non-blocking (let select-loop ([chs channels] [hs handlers]) (if (null? chs) (if (and timeout-secs timeout-thunk) (timeout-thunk) - ;; Spurious wake — retry + ;; Spurious wake — retry (watchers already stopped) (channel-select-wait channels handlers timeout-secs timeout-thunk)) (let-values ([(val ok) (channel-try-get (car chs))]) (if ok --- a/lib/std/net/request.sls +++ b/lib/std/net/request.sls @@ -13,11 +13,21 @@ url-encode build-query-string flatten-request-headers headers->alist - alist->headers) + alist->headers + *http-max-header-size* *http-max-header-count* + *http-max-body-size* *http-max-line-length*) (import (chezscheme) (std net tcp)) + ;; ========== Safety Limits ========== + ;; These prevent denial-of-service from malicious servers. + + (define *http-max-header-size* (make-parameter (* 8 1024))) ;; 8KB per header line + (define *http-max-header-count* (make-parameter 100)) ;; max 100 headers + (define *http-max-body-size* (make-parameter (* 10 1024 1024))) ;; 10MB max body + (define *http-max-line-length* (make-parameter (* 8 1024))) ;; 8KB per line + ;; ========== URL Parsing ========== (define-record-type url-parts @@ -149,18 +159,28 @@ (dynamic-wind (lambda () (void)) (lambda () - ;; Send request line + ;; Send request line — validate path has no CRLF + (when (or (string-find path #\return) (string-find path #\newline)) + (error 'http-request "path contains CRLF (possible injection)" path)) (put-string out (string-append method " " path " HTTP/1.1\r\n")) + ;; Validate host has no CRLF + (when (or (string-find host #\return) (string-find host #\newline)) + (error 'http-request "host contains CRLF (possible injection)" host)) (put-string out (string-append "Host: " host "\r\n")) (put-string out "Connection: close\r\n") - ;; Send custom headers + ;; Send custom headers — validate no CRLF injection (for-each (lambda (h) + (when (or (string-find (car h) #\return) (string-find (car h) #\newline) + (string-find (cdr h) #\return) (string-find (cdr h) #\newline)) + (error 'http-request "header contains CRLF (possible injection)" (car h))) (put-string out (string-append (car h) ": " (cdr h) "\r\n"))) headers) ;; Send body if present + ;; Use byte length (UTF-8) not character length for Content-Length (when data - (put-string out (string-append "Content-Length: " - (number->string (string-length data)) "\r\n"))) + (let ([byte-len (bytevector-length (string->utf8 data))]) + (put-string out (string-append "Content-Length: " + (number->string byte-len) "\r\n")))) (put-string out "\r\n") (when data (put-string out data)) (flush-output-port out) @@ -184,9 +204,12 @@ 0)) (define (read-line-crlf port) - ;; Read until \r\n - (let ([out (open-output-string)]) - (let loop () + ;; Read until \r\n, with max line length to prevent DoS + (let ([out (open-output-string)] + [max-len (*http-max-line-length*)]) + (let loop ([len 0]) + (when (> len max-len) + (error 'http-request "HTTP line too long (possible DoS)" len)) (let ([c (read-char port)]) (cond [(eof-object? c) (get-output-string out)] @@ -196,39 +219,58 @@ (get-output-string out) (begin (write-char c out) (unless (eof-object? next) (write-char next out)) - (loop))))] - [else (write-char c out) (loop)]))))) + (loop (+ len 2)))))] + [else (write-char c out) (loop (+ len 1))]))))) (define (read-headers port) - ;; Read headers until empty line, return alist - (let loop ([headers '()]) - (let ([line (read-line-crlf port)]) - (if (or (string=? line "") (eof-object? line)) - (reverse headers) - (let ([colon-pos (string-find line #\:)]) - (if colon-pos - (let ([key (string-downcase (substring line 0 colon-pos))] - [val (string-trim-left - (substring line (+ colon-pos 1) (string-length line)))]) - (loop (cons (cons key val) headers))) - (loop headers))))))) + ;; Read headers until empty line, return alist. + ;; Enforces max header count and size limits to prevent DoS. + (let ([max-count (*http-max-header-count*)] + [max-size (*http-max-header-size*)]) + (let loop ([headers '()] [count 0]) + (when (> count max-count) + (error 'http-request "too many response headers (possible DoS)" count)) + (let ([line (read-line-crlf port)]) + (when (and (string? line) (> (string-length line) max-size)) + (error 'http-request "response header too long (possible DoS)" + (string-length line))) + (if (or (string=? line "") (eof-object? line)) + (reverse headers) + (let ([colon-pos (string-find line #\:)]) + (if colon-pos + (let ([key (string-downcase (substring line 0 colon-pos))] + [val (string-trim-left + (substring line (+ colon-pos 1) (string-length line)))]) + (loop (cons (cons key val) headers) (+ count 1))) + (loop headers count)))))))) (define (read-body port headers) - ;; Read body based on Content-Length or until EOF - (let ([cl (assoc "content-length" headers)]) + ;; Read body based on Content-Length or until EOF. + ;; Enforces max body size to prevent OOM from malicious servers. + (let ([max-body (*http-max-body-size*)] + [cl (assoc "content-length" headers)]) (if cl (let ([len (string->number (cdr cl))]) - (if (and len (> len 0)) - (let ([buf (get-string-n port len)]) - (if (eof-object? buf) "" buf)) - "")) - ;; No content-length — read until EOF + (cond + [(not len) ""] + [(<= len 0) ""] + [(> len max-body) + (error 'http-request + "Content-Length exceeds maximum body size" + len max-body)] + [else + (let ([buf (get-string-n port len)]) + (if (eof-object? buf) "" buf))])) + ;; No content-length — read until EOF with size limit (let ([out (open-output-string)]) - (let loop () + (let loop ([total 0]) + (when (> total max-body) + (error 'http-request + "response body exceeds maximum size (no Content-Length)" max-body)) (let ([c (read-char port)]) (if (eof-object? c) (get-output-string out) - (begin (write-char c out) (loop))))))))) + (begin (write-char c out) (loop (+ total 1)))))))))) ;; ========== Helpers ========== --- a/lib/std/security/capability.sls +++ b/lib/std/security/capability.sls @@ -92,11 +92,21 @@ (cdr (assq 'execute (capability-permissions cap))))) (define (fs-allowed-path? cap path) - ;; Check if path is under one of the allowed paths + ;; Check if path is under one of the allowed paths. + ;; HARDENED: Requires directory boundary — /tmp/safe does NOT match /tmp/safety. + ;; The allowed path must be either an exact match or followed by '/'. (and (eq? (capability-type cap) 'filesystem) (let ([allowed (cdr (assq 'paths (capability-permissions cap)))] [canonical (canonicalize-path path)]) - (exists (lambda (p) (string-prefix? p canonical)) allowed)))) + (exists (lambda (p) + (or (string=? p canonical) ;; exact match + (string=? p "/") ;; root allows everything + (and (string-prefix? p canonical) + ;; Must be at a directory boundary + (let ([plen (string-length p)]) + (or (char=? (string-ref canonical plen) #\/) + (char=? (string-ref p (- plen 1)) #\/)))))) + allowed)))) ;; FFI binding for realpath(3) — resolves symlinks and . / .. (define c-realpath --- a/lib/std/security/sandbox.sls +++ b/lib/std/security/sandbox.sls @@ -158,100 +158,165 @@ (%sandbox-config-landlock cfg) (%sandbox-config-capabilities cfg))))) + ;; FFI pipe(2) — creates a pair of connected file descriptors + (define c-pipe + (guard (exn [#t #f]) + (foreign-procedure "pipe" (u8*) int))) + + (define c-read + (guard (exn [#t #f]) + (foreign-procedure "read" (int u8* size_t) ssize_t))) + + (define c-write + (guard (exn [#t #f]) + (foreign-procedure "write" (int u8* size_t) ssize_t))) + + (define c-close + (guard (exn [#t #f]) + (foreign-procedure "close" (int) int))) + + (define (make-pipe) + ;; Returns (values read-fd write-fd) or raises error + (let ([buf (make-bytevector 8 0)]) ;; 2 ints + (let ([rc (if c-pipe (c-pipe buf) -1)]) + (when (< rc 0) + (error 'make-pipe "pipe(2) failed")) + (values (bytevector-s32-native-ref buf 0) + (bytevector-s32-native-ref buf 4))))) + + (define (fd-write-all fd bv) + ;; Write entire bytevector to fd + (let ([len (bytevector-length bv)]) + (let loop ([offset 0]) + (when (< offset len) + (let ([n (c-write fd (subbytevector bv offset len) (- len offset))]) + (when (<= n 0) + (error 'fd-write-all "write failed")) + (loop (+ offset n))))))) + + (define (subbytevector bv start end) + (let* ([len (- end start)] + [result (make-bytevector len)]) + (bytevector-copy! bv start result 0 len) + result)) + + (define (fd-read-all fd max-size) + ;; Read up to max-size bytes from fd until EOF + (let ([buf (make-bytevector 4096)]) + (let loop ([chunks '()] [total 0]) + (let ([n (c-read fd buf 4096)]) + (cond + [(<= n 0) + ;; EOF or error — assemble result + (let ([result (make-bytevector total)]) + (let copy-loop ([chunks (reverse chunks)] [offset 0]) + (if (null? chunks) result + (let ([chunk (car chunks)]) + (bytevector-copy! chunk 0 result offset (bytevector-length chunk)) + (copy-loop (cdr chunks) (+ offset (bytevector-length chunk)))))))] + [(> (+ total n) max-size) + (error 'fd-read-all "data exceeds maximum size" max-size)] + [else + (let ([chunk (make-bytevector n)]) + (bytevector-copy! buf 0 chunk 0 n) + (loop (cons chunk chunks) (+ total n)))]))))) + (define (run-safe-internal thunk timeout seccomp-filter landlock-rules capabilities) - ;; Communication via temp file: child writes result, parent reads it. - ;; This avoids FFI pipe() dependency while keeping fork-based isolation. - (let* ([tmp-file (format "/tmp/jerboa-sandbox-~a" (random 1000000000))] - [pid (fork-process)]) - (if (= pid 0) - ;; === CHILD PROCESS === - (guard (exn - [#t - ;; Send error to parent via temp file - (guard (exn2 [#t (exit 2)]) - (call-with-output-file tmp-file - (lambda (port) - (write (list 'error - (cond - [(sandbox-error? exn) - (let ([phase (sandbox-error-phase exn)] - [detail (sandbox-error-detail exn)]) - (format "~a: ~a" phase detail))] - [(message-condition? exn) - (condition-message exn)] - [else "unknown sandbox error"])) - port)) - 'replace)) - (exit 1)]) - - ;; Step 1: Install Landlock - (when (and landlock-rules (landlock-available?)) - (landlock-install! landlock-rules)) - - ;; Step 2: Install seccomp (after file write setup, since seccomp may block writes) - ;; Note: we defer seccomp install to after computing result if using strict filters, - ;; because we need to write the result file. For io-only filter this works fine. - (when (and seccomp-filter (seccomp-available?)) - (seccomp-install! seccomp-filter)) - - ;; Step 3: Set capabilities - (unless (null? capabilities) - (current-capabilities capabilities)) - - ;; Step 4: Run thunk with timeout - (let ([result - (if timeout - (let ([completed #f] - [value (void)]) - (let ([engine (make-engine (lambda () (thunk)))]) - (engine (* timeout 10000000) ;; ~10M ticks/sec - (lambda (ticks val) - (set! completed #t) - (set! value val)) - (lambda (new-engine) - (set! completed #f)))) - (unless completed - (raise (make-sandbox-error - "sandbox" - 'timeout - (format "execution exceeded ~a second timeout" - timeout)))) - value) - (thunk))]) - - ;; Step 5: Send result to parent - (call-with-output-file tmp-file - (lambda (port) (write (list 'ok result) port)) - 'replace) - (exit 0))) - - ;; === PARENT PROCESS === - (begin - ;; Wait for child to exit - (let-values ([(wpid status) (waitpid pid)]) - (let ([result-sexp - (guard (exn [#t (list 'error "failed to read child result")]) - (if (file-exists? tmp-file) - (let ([sexp (call-with-input-file tmp-file read)]) - (delete-file tmp-file) - sexp) - (list 'error (format "child exited with status ~a, no result file" - status))))]) - ;; Clean up temp file if still present - (when (file-exists? tmp-file) (delete-file tmp-file)) - (cond - [(and (pair? result-sexp) (eq? (car result-sexp) 'ok)) - (cadr result-sexp)] - [(and (pair? result-sexp) (eq? (car result-sexp) 'error)) - (raise (make-sandbox-error - "sandbox" - 'eval - (cadr result-sexp)))] - [else - (raise (make-sandbox-error - "sandbox" - 'fork - (format "child exited with status ~a" status)))]))))))) + ;; Communication via pipe: child writes result, parent reads it. + ;; HARDENED: Uses pipe(2) instead of temp files to prevent symlink attacks, + ;; TOCTOU races, and read-eval injection. + (let-values ([(read-fd write-fd) (make-pipe)]) + (let ([pid (fork-process)]) + (if (= pid 0) + ;; === CHILD PROCESS === + (begin + ;; Close read end — child only writes + (c-close read-fd) + (guard (exn + [#t + ;; Send error to parent via pipe + (guard (exn2 [#t (c-close write-fd) (exit 2)]) + (let ([msg (cond + [(sandbox-error? exn) + (format "~a: ~a" + (sandbox-error-phase exn) + (sandbox-error-detail exn))] + [(message-condition? exn) + (condition-message exn)] + [else "unknown sandbox error"])]) + (let ([data (string->utf8 (format "(error ~s)" msg))]) + (fd-write-all write-fd data) + (c-close write-fd)))) + (exit 1)]) + + ;; Step 1: Install Landlock + (when (and landlock-rules (landlock-available?)) + (landlock-install! landlock-rules)) + + ;; Step 2: Install seccomp AFTER setting up pipe + ;; Pipe fd is already open, so even compute-only filter works + (when (and seccomp-filter (seccomp-available?)) + (seccomp-install! seccomp-filter)) + + ;; Step 3: Set capabilities + (unless (null? capabilities) + (current-capabilities capabilities)) + + ;; Step 4: Run thunk with timeout + (let ([result + (if timeout + (let ([completed #f] + [value (void)]) + (let ([engine (make-engine (lambda () (thunk)))]) + (engine (* timeout 10000000) + (lambda (ticks val) + (set! completed #t) + (set! value val)) + (lambda (new-engine) + (set! completed #f)))) + (unless completed + (raise (make-sandbox-error + "sandbox" + 'timeout + (format "execution exceeded ~a second timeout" + timeout)))) + value) + (thunk))]) + + ;; Step 5: Send result to parent via pipe + (let ([data (string->utf8 (format "(ok ~s)" result))]) + (fd-write-all write-fd data) + (c-close write-fd) + (exit 0))))) + + ;; === PARENT PROCESS === + (begin + ;; Close write end — parent only reads + (c-close write-fd) + (let-values ([(wpid status) (waitpid pid)]) + (let* ([raw-data (guard (exn [#t (make-bytevector 0)]) + (fd-read-all read-fd (* 1 1024 1024)))] ;; 1MB max + [_ (c-close read-fd)] + [result-sexp + (if (> (bytevector-length raw-data) 0) + (guard (exn [#t (list 'error "failed to parse child result")]) + (let ([str (utf8->string raw-data)]) + (read (open-input-string str)))) + (list 'error (format "child exited with status ~a, no output" + status)))]) + (cond + [(and (pair? result-sexp) (eq? (car result-sexp) 'ok)) + (cadr result-sexp)] + [(and (pair? result-sexp) (eq? (car result-sexp) 'error)) + (raise (make-sandbox-error + "sandbox" + 'eval + (cadr result-sexp)))] + [else + (raise (make-sandbox-error + "sandbox" + 'fork + (format "child exited with status ~a" status)))])))))))) ;; ========== FFI Initialization ==========