Fix Slang-to-WASM review findings: security, correctness, and test coverage
ober
572590a27d2f9651fa620ad6129186cf25860d66
--- a/jerboa-native-rs/src/wasm.rs +++ b/jerboa-native-rs/src/wasm.rs @@ -28,6 +28,11 @@ struct WasmModule { module: Module, } +/// Maximum number of log entries per instance (prevents memory exhaustion) +const LOG_BUFFER_CAP: usize = 10_000; +/// Maximum CDB file size (256 MB) +const CDB_MAX_FILE_SIZE: u64 = 256 * 1024 * 1024; + /// Host state available to WASM import functions. struct HostState { /// Monotonic clock offset (ms since instance start) @@ -42,6 +47,8 @@ struct HostState { cdb_handles: HashMap<i32, Vec<u8>>, /// Counter for allocating CDB handles next_cdb_handle: i32, + /// Allowed directories for CDB file opens (empty = deny all) + allowed_cdb_dirs: Vec<String>, } impl Default for HostState { @@ -53,6 +60,7 @@ impl Default for HostState { peer_addr: None, cdb_handles: HashMap::new(), next_cdb_handle: 0, + allowed_cdb_dirs: Vec::new(), } } } @@ -244,6 +252,50 @@ pub extern "C" fn jerboa_wasm_set_socket(instance_handle: u64, fd: i32) -> i32 { }) } +/// Add an allowed directory for CDB file opens. +/// The WASM guest can only open CDB files under these directories. +/// path_ptr/path_len: UTF-8 directory path. +/// Returns 0 on success, -1 on error. +#[no_mangle] +pub extern "C" fn jerboa_wasm_allow_cdb_dir( + instance_handle: u64, + path_ptr: *const u8, + path_len: usize, +) -> i32 { + ffi_wrap(|| { + if path_ptr.is_null() { + set_last_error("null path pointer".to_string()); + return -1; + } + let path_bytes = unsafe { std::slice::from_raw_parts(path_ptr, path_len) }; + let path_str = match std::str::from_utf8(path_bytes) { + Ok(s) => s, + Err(_) => { + set_last_error("invalid UTF-8 in path".to_string()); + return -1; + } + }; + // Canonicalize the directory path + let canonical = match std::fs::canonicalize(path_str) { + Ok(p) => p.to_string_lossy().to_string(), + Err(e) => { + set_last_error(format!("canonicalize failed: {e}")); + return -1; + } + }; + let mut instances = wasm_instances().lock().unwrap(); + let inst = match instances.get_mut(&instance_handle) { + Some(i) => i, + None => { + set_last_error("invalid instance handle".to_string()); + return -1; + } + }; + inst.store.data_mut().allowed_cdb_dirs.push(canonical); + 0 + }) +} + /// Add fuel to an existing instance. /// Returns 0 on success, -1 on error. #[no_mangle] @@ -539,6 +591,37 @@ pub extern "C" fn jerboa_wasm_memory_size(handle: u64) -> i64 { } } +/// Retrieve the log buffer from a hosted instance as a newline-separated UTF-8 string. +/// Writes into buf_ptr (up to buf_max bytes). Returns total log length (may exceed buf_max). +/// Returns -1 on error. +#[no_mangle] +pub extern "C" fn jerboa_wasm_get_log( + handle: u64, + buf_ptr: *mut u8, + buf_max: usize, +) -> i64 { + match std::panic::catch_unwind(|| { + let instances = wasm_instances().lock().unwrap(); + let inst = match instances.get(&handle) { + Some(i) => i, + None => return -1i64, + }; + let log = &inst.store.data().log_buffer; + let full = log.join("\n"); + let bytes = full.as_bytes(); + if !buf_ptr.is_null() && buf_max > 0 { + let copy_len = bytes.len().min(buf_max); + unsafe { + std::ptr::copy_nonoverlapping(bytes.as_ptr(), buf_ptr, copy_len); + } + } + bytes.len() as i64 + }) { + Ok(v) => v, + Err(_) => -1, + } +} + // ============================================================ // Hosted instance: instantiate with WASI + DNS host imports // ============================================================ @@ -763,7 +846,10 @@ fn define_host_imports(linker: &mut Linker<HostState>) -> Result<(), Error> { 0 => "ERROR", 1 => "WARN", 2 => "INFO", _ => "DEBUG", }; eprintln!("[wasm-{lvl}] {msg}"); - caller.data_mut().log_buffer.push(format!("[{lvl}] {msg}")); + let state = caller.data_mut(); + if state.log_buffer.len() < LOG_BUFFER_CAP { + state.log_buffer.push(format!("[{lvl}] {msg}")); + } 0 } )?; @@ -829,7 +915,7 @@ fn define_host_imports(linker: &mut Linker<HostState>) -> Result<(), Error> { data[start..end].to_vec() }; // Optionally parse destination address from WASM memory. - let dest_addr: Option<std::net::SocketAddr> = if addr_len > 0 { + let target: Option<std::net::SocketAddr> = if addr_len > 0 { let addr_str = { let data = memory.data(&caller); let start = addr_ptr as usize; @@ -837,12 +923,19 @@ fn define_host_imports(linker: &mut Linker<HostState>) -> Result<(), Error> { if end > data.len() { return -1; } std::str::from_utf8(&data[start..end]).ok().map(str::to_string) }; - addr_str.and_then(|s| s.parse().ok()) + // If explicit address was provided but can't be parsed, fail + // (don't silently fall back to peer_addr) + match addr_str { + Some(s) => match s.parse() { + Ok(a) => Some(a), + Err(_) => return -1, + }, + None => return -1, + } } else { - None + // No explicit address: use saved peer from last recv + caller.data().peer_addr }; - // Prefer explicit address; fall back to saved peer from last recv. - let target = dest_addr.or_else(|| caller.data().peer_addr); let cloned = caller.data().udp_socket.as_ref() .and_then(|s| s.try_clone().ok()); match (cloned, target) { @@ -859,7 +952,8 @@ fn define_host_imports(linker: &mut Linker<HostState>) -> Result<(), Error> { // ---- DNS: cdb_open (path_ptr, path_len) -> handle ---- // Reads the entire CDB file into memory and returns a handle (>=0). - // Returns -1 on error (file not found, I/O error, etc.). + // Returns -1 on error (file not found, I/O error, path not allowed, etc.). + // SECURITY: Only paths under allowed_cdb_dirs are permitted. linker.func_wrap( "dns", "cdb_open", |mut caller: Caller<'_, HostState>, path_ptr: i32, path_len: i32| -> i32 { @@ -877,7 +971,28 @@ fn define_host_imports(linker: &mut Linker<HostState>) -> Result<(), Error> { Err(_) => return -1, } }; - let cdb_data = match std::fs::read(&path) { + // Resolve to canonical path to prevent traversal via ../ or symlinks + let canonical = match std::fs::canonicalize(&path) { + Ok(p) => p, + Err(_) => return -1, + }; + let canonical_str = canonical.to_string_lossy(); + // Check path is under an allowed directory + let allowed = &caller.data().allowed_cdb_dirs; + if allowed.is_empty() || !allowed.iter().any(|dir| canonical_str.starts_with(dir)) { + eprintln!("[wasm-WARN] cdb_open denied: {canonical_str} not in allowed dirs"); + return -1; + } + // Check file size before reading + let meta = match std::fs::metadata(&canonical) { + Ok(m) => m, + Err(_) => return -1, + }; + if meta.len() > CDB_MAX_FILE_SIZE { + eprintln!("[wasm-WARN] cdb_open denied: file too large ({} bytes)", meta.len()); + return -1; + } + let cdb_data = match std::fs::read(&canonical) { Ok(d) => d, Err(_) => return -1, }; --- a/lib/jerboa/wasm/scheme-runtime.sls +++ b/lib/jerboa/wasm/scheme-runtime.sls @@ -574,23 +574,38 @@ (set! cnt (+ cnt 1))) (scheme-write-bytes (+ pos 1) cnt)))) - ;; Display a Scheme value to log (no explicit newline; - ;; each log_message call becomes one log line on the host side). + ;; Display a Scheme value to log. + ;; Handles: strings, fixnums, booleans (#t/#f), nil (), void. (define (scheme-display val) (if (is-string val) (scheme-write-string val) (if (is-number val) (scheme-write-fixnum-raw (untag-fixnum val)) - 0))) - - ;; Display a Scheme value (equivalent to scheme-display; each call - ;; is its own log line, so the newline is implicit). + ;; Immediates: #t=2, #f=0, ()=4, void=6, eof=8 + (if (= val 2) + ;; #t + (begin (i32.store8 4096 35) (i32.store8 4097 116) + (scheme-write-bytes 4096 2)) + (if (= val 0) + ;; #f + (begin (i32.store8 4096 35) (i32.store8 4097 102) + (scheme-write-bytes 4096 2)) + (if (= val 4) + ;; () + (begin (i32.store8 4096 40) (i32.store8 4097 41) + (scheme-write-bytes 4096 2)) + ;; void or unknown — no output + 0)))))) + + ;; Display a Scheme value followed by a newline. (define (scheme-displayln val) - (scheme-display val)) + (scheme-display val) + (scheme-newline)) - ;; Log a blank line (empty message). + ;; Write a newline character (0x0A) to log. (define (scheme-newline) - (log_message 2 4096 0)) + (i32.store8 4108 10) + (log_message 2 4108 1)) )) ;; ================================================================ --- a/lib/std/secure/wasm-target.sls +++ b/lib/std/secure/wasm-target.sls @@ -282,6 +282,15 @@ bindings)]) `(let* ,new-bindings ,@(map lower-expr body)))] + ;; letrec/letrec*: lower to let* with set! (valid for WASM flat scope) + [(letrec letrec*) + (let* ([bindings (car args)] + [body (cdr args)] + ;; Initialize all vars to void, then set! each + [init-bindings (map (lambda (b) (list (car b) IMM-VOID)) bindings)] + [set-forms (map (lambda (b) `(set! ,(car b) ,(lower-expr (cadr b)))) bindings)]) + `(let* ,init-bindings ,@set-forms ,@(map lower-expr body)))] + ;; ---- Control flow (pass through) ---- [(if) (let ([test (lower-expr (car args))] @@ -317,10 +326,11 @@ [(null? args) IMM-FALSE] [(null? (cdr args)) (lower-expr (car args))] [else - `(let ([__or_tmp ,(lower-expr (car args))]) - (if (is-truthy __or_tmp) - __or_tmp - ,(lower-expr `(or ,@(cdr args)))))])] + (let ([tmp (gensym-init 'or)]) + `(let ([,tmp ,(lower-expr (car args))]) + (if (is-truthy ,tmp) + ,tmp + ,(lower-expr `(or ,@(cdr args))))))])] [(begin) `(begin ,@(map lower-expr args))] @@ -345,16 +355,31 @@ `(wasm-bool->scheme (scheme-list? ,(lower-expr (car args))))] ;; Arithmetic — operands are tagged fixnums + ;; Multi-arg: (+ a b c) → (fx+ (fx+ a b) c), etc. [(+) - (if (null? (cdr args)) - (lower-expr (car args)) - `(fx+ ,(lower-expr (car args)) ,(lower-expr (cadr args))))] + (cond + [(null? args) (tagged-fixnum 0)] ;; (+) → 0 + [(null? (cdr args)) (lower-expr (car args))] + [else (let loop ([rest (cddr args)] + [acc `(fx+ ,(lower-expr (car args)) ,(lower-expr (cadr args)))]) + (if (null? rest) acc + (loop (cdr rest) `(fx+ ,acc ,(lower-expr (car rest))))))])] [(-) - (if (null? (cdr args)) - `(fx-negate ,(lower-expr (car args))) - `(fx- ,(lower-expr (car args)) ,(lower-expr (cadr args))))] + (cond + [(null? (cdr args)) + `(fx-negate ,(lower-expr (car args)))] + [else (let loop ([rest (cddr args)] + [acc `(fx- ,(lower-expr (car args)) ,(lower-expr (cadr args)))]) + (if (null? rest) acc + (loop (cdr rest) `(fx- ,acc ,(lower-expr (car rest))))))])] [(*) - `(fx* ,(lower-expr (car args)) ,(lower-expr (cadr args)))] + (cond + [(null? args) (tagged-fixnum 1)] ;; (*) → 1 + [(null? (cdr args)) (lower-expr (car args))] + [else (let loop ([rest (cddr args)] + [acc `(fx* ,(lower-expr (car args)) ,(lower-expr (cadr args)))]) + (if (null? rest) acc + (loop (cdr rest) `(fx* ,acc ,(lower-expr (car rest))))))])] [(/) `(fx/ ,(lower-expr (car args)) ,(lower-expr (cadr args)))] [(modulo remainder) @@ -396,6 +421,21 @@ [(not) `(if (is-truthy ,(lower-expr (car args))) ,IMM-FALSE ,IMM-TRUE)] + ;; Arithmetic extras + [(min) + (let ([a (lower-expr (car args))] [b (lower-expr (cadr args))]) + `(let ([__min_a ,a] [__min_b ,b]) + (if (fx< __min_a __min_b) __min_a __min_b)))] + [(max) + (let ([a (lower-expr (car args))] [b (lower-expr (cadr args))]) + `(let ([__max_a ,a] [__max_b ,b]) + (if (fx> __max_a __max_b) __max_a __max_b)))] + [(even?) + `(fx= (fx-bitwise-and ,(lower-expr (car args)) ,(tagged-fixnum 1)) ,(tagged-fixnum 0))] + [(odd?) + `(if (fx= (fx-bitwise-and ,(lower-expr (car args)) ,(tagged-fixnum 1)) ,(tagged-fixnum 0)) + ,IMM-FALSE ,IMM-TRUE)] + ;; Type predicates [(number? integer?) `(wasm-bool->scheme (is-number ,(lower-expr (car args))))] @@ -468,6 +508,23 @@ `(scheme-string-ref ,(lower-expr (car args)) ,(lower-expr (cadr args)))] [(string=?) `(scheme-string=? ,(lower-expr (car args)) ,(lower-expr (cadr args)))] + [(string-append) + ;; (string-append a b ...) → runtime concatenation via scheme-string-append + ;; Fold pairwise: (string-append a b c) → (scheme-string-append (scheme-string-append a b) c) + (cond + [(null? args) `(string-from-static ,(string->utf8 ""))] + [(null? (cdr args)) (lower-expr (car args))] + [else (let loop ([rest (cddr args)] + [acc `(scheme-string-append ,(lower-expr (car args)) + ,(lower-expr (cadr args)))]) + (if (null? rest) acc + (loop (cdr rest) + `(scheme-string-append ,acc ,(lower-expr (car rest))))))])] + [(number->string) + ;; Convert tagged fixnum to string object via write-fixnum-raw + alloc + `(scheme-number->string ,(lower-expr (car args)))] + [(string->number) + `(scheme-string->number ,(lower-expr (car args)))] ;; Vector operations [(make-vector) @@ -649,49 +706,65 @@ (pair? (cadr rest)) (eq? (caadr rest) 'finally) (cadr rest))))]) - (let ([try-body (lower-expr body)]) + (let* ([try-body (lower-expr body)] + [finally-body (if finally-clause + (map lower-expr (cdr finally-clause)) + '())]) (if catch-clause (let* ([catch-args (cdr catch-clause)] [catch-bindings (car catch-args)] [catch-body (cdr catch-args)] - [e-var (if (pair? catch-bindings) (car catch-bindings) catch-bindings)]) - (if finally-clause - `(try-catch 0 - ,try-body - ,e-var - (begin ,@(map lower-expr catch-body))) - `(try-catch 0 - ,try-body - ,e-var - (begin ,@(map lower-expr catch-body))))) - try-body)))] + [e-var (if (pair? catch-bindings) (car catch-bindings) catch-bindings)] + [core `(try-catch 0 + ,try-body + ,e-var + (begin ,@(map lower-expr catch-body)))]) + (if (null? finally-body) + core + ;; Wrap: store try-catch result, run finally, return result + `(let ([__try_result ,core]) + ,@finally-body + __try_result))) + ;; No catch clause — just body + finally + (if (null? finally-body) + try-body + `(let ([__try_result ,try-body]) + ,@finally-body + __try_result)))))] ;; ---- Output / display forms ---- - ;; (displayln x) → scheme-displayln (one log line per call) - ;; (displayln) → scheme-newline (blank log line) + ;; (displayln x ...) → display all args, then newline + ;; (displayln) → just newline [(displayln) (if (null? args) `(scheme-newline) - `(scheme-displayln ,(lower-expr (car args))))] + `(begin ,@(map (lambda (a) `(scheme-display ,(lower-expr a))) args) + (scheme-newline)))] - ;; (display x) → scheme-display + ;; (display x) → scheme-display (single arg only; zero args is invalid) [(display) - (if (null? args) - `(scheme-newline) - `(scheme-display ,(lower-expr (car args))))] + (cond + [(null? args) IMM-VOID] ;; (display) with no args → void (no-op) + [(null? (cdr args)) `(scheme-display ,(lower-expr (car args)))] + [else `(begin ,@(map (lambda (a) `(scheme-display ,(lower-expr a))) args))])] ;; (newline) → scheme-newline [(newline) `(scheme-newline)] - ;; (format str) → static string; (format str args...) → ignored for now - ;; MVP: if called with a literal string and no interpolation args, - ;; return the string; otherwise return first arg unchanged. + ;; (format str args...) → basic ~a substitution + ;; For literal format strings: expand ~a directives inline. + ;; For non-literal: return first arg (best effort). [(format) (if (and (string? (car args)) (null? (cdr args))) + ;; Literal string with no args → static string `(string-from-static ,(string->utf8 (car args))) - (lower-expr (car args)))] + (if (string? (car args)) + ;; Literal format string with args → expand ~a + (lower-format-string (car args) (cdr args)) + ;; Dynamic format string → just display it + (lower-expr (car args))))] ;; (assert! expr) or (assert! expr "message") [(assert!) @@ -701,6 +774,27 @@ (lower-expr (cadr args)) (tagged-fixnum 0)))))] + ;; (error who msg irritants...) → throw with message string + [(error) + (if (and (pair? (cdr args)) (string? (cadr args))) + `(throw 0 ,(lower-expr (cadr args))) + `(throw 0 ,(tagged-fixnum 0)))] + + ;; (void) → void immediate + [(void) + IMM-VOID] + + ;; (values x) → just x (single-value case; multi-value not supported) + [(values) + (if (null? (cdr args)) + (lower-expr (car args)) + (lower-expr (car args)))] + + ;; (apply f lst) → runtime apply (limited: only for known small arities) + [(apply) + ;; Fall through to default — apply is a function call to scheme-apply + `(scheme-apply ,(lower-expr (car args)) ,(lower-expr (cadr args)))] + ;; ---- Quote ---- [(quote) (lower-quoted (car args))] @@ -715,6 +809,68 @@ [else expr])) + ;; Expand a format string with ~a directives to a begin block of scheme-display calls. + ;; "hello ~a, you are ~a" with args (name age) → + ;; (begin (scheme-display "hello ") (scheme-display name) (scheme-display ", you are ") + ;; (scheme-display age)) + (define (lower-format-string fmt-str fmt-args) + (let loop ([i 0] [args fmt-args] [parts '()] [current ""]) + (cond + [(>= i (string-length fmt-str)) + ;; End of format string — flush current literal and assemble + (let ([final-parts (if (> (string-length current) 0) + (cons `(scheme-display (string-from-static ,(string->utf8 current))) parts) + parts)]) + (if (null? final-parts) + IMM-VOID + `(begin ,@(reverse final-parts))))] + ;; ~a directive: flush current literal, emit arg display + [(and (char=? (string-ref fmt-str i) #\~) + (< (+ i 1) (string-length fmt-str)) + (char=? (string-ref fmt-str (+ i 1)) #\a)) + (let* ([literal-part (if (> (string-length current) 0) + (list `(scheme-display (string-from-static ,(string->utf8 current)))) + '())] + [arg-part (if (pair? args) + (list `(scheme-display ,(lower-expr (car args)))) + '())] + [remaining-args (if (pair? args) (cdr args) '())]) + (loop (+ i 2) remaining-args + (append (reverse arg-part) (reverse literal-part) parts) + ""))] + ;; ~~ escape: emit single ~ + [(and (char=? (string-ref fmt-str i) #\~) + (< (+ i 1) (string-length fmt-str)) + (char=? (string-ref fmt-str (+ i 1)) #\~)) + (loop (+ i 2) args parts (string-append current "~"))] + ;; ~s directive: same as ~a for now (no write-style quoting in WASM) + [(and (char=? (string-ref fmt-str i) #\~) + (< (+ i 1) (string-length fmt-str)) + (char=? (string-ref fmt-str (+ i 1)) #\s)) + (let* ([literal-part (if (> (string-length current) 0) + (list `(scheme-display (string-from-static ,(string->utf8 current)))) + '())] + [arg-part (if (pair? args) + (list `(scheme-display ,(lower-expr (car args)))) + '())] + [remaining-args (if (pair? args) (cdr args) '())]) + (loop (+ i 2) remaining-args + (append (reverse arg-part) (reverse literal-part) parts) + ""))] + ;; ~n directive: newline + [(and (char=? (string-ref fmt-str i) #\~) + (< (+ i 1) (string-length fmt-str)) + (char=? (string-ref fmt-str (+ i 1)) #\n)) + (let ([literal-part (if (> (string-length current) 0) + (list `(scheme-display (string-from-static ,(string->utf8 current)))) + '())]) + (loop (+ i 2) args + (cons `(scheme-newline) (append (reverse literal-part) parts)) + ""))] + ;; Regular character + [else + (loop (+ i 1) args parts (string-append current (string (string-ref fmt-str i))))]))) + ;; Lower guard clauses: (guard (e [test body] ...) ...) (define (lower-guard-clauses var clauses) (if (null? clauses) @@ -1132,41 +1288,32 @@ ;; Load closure type pre-registration forms from scheme-runtime module. (define (closure-type-forms) - (let ([rt (with-exception-handler - (lambda (e) '()) - (lambda () - (eval '(begin - (import (jerboa wasm scheme-runtime)) - runtime-closure-type-forms) - (environment '(chezscheme) '(jerboa wasm scheme-runtime)))) - #:handle-all)]) + (let ([rt (guard (e [#t '()]) + (eval '(begin + (import (jerboa wasm scheme-runtime)) + runtime-closure-type-forms) + (environment '(chezscheme) '(jerboa wasm scheme-runtime))))]) (if (pair? rt) rt '()))) ;; Load closure runtime dispatch forms (call-closure-1/2/3) from scheme-runtime. ;; Only included when closures are present — these forms use call_indirect which ;; requires a function table. (define (closure-runtime-forms) - (let ([rt (with-exception-handler - (lambda (e) '()) - (lambda () - (eval '(begin - (import (jerboa wasm scheme-runtime)) - runtime-closure-forms) - (environment '(chezscheme) '(jerboa wasm scheme-runtime)))) - #:handle-all)]) + (let ([rt (guard (e [#t '()]) + (eval '(begin + (import (jerboa wasm scheme-runtime)) + runtime-closure-forms) + (environment '(chezscheme) '(jerboa wasm scheme-runtime))))]) (if (pair? rt) rt '()))) ;; Load display runtime forms from scheme-runtime. ;; Only included in full Slang pipeline (requires log_message from dns imports). (define (display-runtime-forms) - (let ([rt (with-exception-handler - (lambda (e) '()) - (lambda () - (eval '(begin - (import (jerboa wasm scheme-runtime)) - runtime-display-forms) - (environment '(chezscheme) '(jerboa wasm scheme-runtime)))) - #:handle-all)]) + (let ([rt (guard (e [#t '()]) + (eval '(begin + (import (jerboa wasm scheme-runtime)) + runtime-display-forms) + (environment '(chezscheme) '(jerboa wasm scheme-runtime))))]) (if (pair? rt) rt '()))) ;; Check if any form references closures @@ -1185,15 +1332,11 @@ (define (runtime-forms) ;; These are loaded at compile time from the scheme-runtime module ;; We inline them here to avoid a circular dependency - (let ([rt (with-exception-handler - (lambda (e) '()) - (lambda () - (let () - (eval '(begin - (import (jerboa wasm scheme-runtime)) - runtime-all-forms) - (environment '(chezscheme) '(jerboa wasm scheme-runtime)))) - #:handle-all)]) + (let ([rt (guard (e [#t '()]) + (eval '(begin + (import (jerboa wasm scheme-runtime)) + runtime-all-forms) + (environment '(chezscheme) '(jerboa wasm scheme-runtime))))]) (if (pair? rt) rt ;; Fallback: minimal runtime if module not available '()))) --- a/lib/std/wasm/sandbox.sls +++ b/lib/std/wasm/sandbox.sls @@ -44,7 +44,10 @@ wasm-sandbox-available? ;; Hosted instance (WASI + DNS imports) - wasm-sandbox-instantiate-hosted) + wasm-sandbox-instantiate-hosted + + ;; Log buffer retrieval (hosted instances) + wasm-sandbox-get-log) (import (chezscheme)) @@ -122,6 +125,12 @@ (foreign-procedure "jerboa_wasm_instance_new_hosted" (unsigned-64 unsigned-64) unsigned-64)))) + (define c-wasm-get-log + (and _native-loaded + (guard (e [#t #f]) + (foreign-procedure "jerboa_wasm_get_log" + (unsigned-64 u8* size_t) integer-64)))) + (define c-last-error (and _native-loaded (guard (e [#t #f]) @@ -268,6 +277,21 @@ (error 'wasm-sandbox-instantiate-hosted (last-error))) h))) + ;; --- Log buffer retrieval --- + + (define (wasm-sandbox-get-log handle) + ;; Retrieve the log buffer from a hosted WASM instance as a string. + ;; Returns "" if log retrieval is not available. + (if (not c-wasm-get-log) + "" + (let ([buf (make-bytevector 65536)]) + (let ([n (c-wasm-get-log handle buf 65536)]) + (if (> n 0) + (utf8->string (let ([r (make-bytevector (min n 65535))]) + (bytevector-copy! buf 0 r 0 (min n 65535)) + r)) + ""))))) + ;; --- Helpers --- (define (extract-opt opts key default) --- a/tests/test-wasm-sandbox.ss +++ b/tests/test-wasm-sandbox.ss @@ -413,6 +413,193 @@ 31) ;; tag-fixnum(15) = 31 ;;; ============================================================ +;;; Section 8: Try-catch execution in wasmi +;;; ============================================================ +(printf "~%--- Section 8: Try-catch execution in wasmi ---~%") + +;; NOTE: wasmi 0.40 does not support the exception-handling WASM proposal. +;; try-catch compiles to valid WASM binary (tested in test-slang-wasm.ss) +;; but cannot execute in wasmi until it adds exception support. +;; These tests verify the compilation succeeds and document the limitation. + +(test "try-catch compiles to valid WASM" + (bytevector? + (compile-program + (append + value-memory-forms + value-global-forms + value-tag-forms + '((define-tag 0) + (define (safe-div a b) + (try-catch 0 + (if (= b 0) (throw 0 -1) (quotient a b)) + exn + exn)))))) + #t) + +(test "try-catch wasmi rejects with clear error (exception-handling not supported)" + (guard (exn [#t (and (message-condition? exn) + (string-contains (condition-message exn) "legacy exceptions") #t)]) + (let* ([bv (compile-program + (append + value-memory-forms + value-global-forms + value-tag-forms + '((define-tag 0) + (define (safe-div a b) + (try-catch 0 + (if (= b 0) (throw 0 -1) (quotient a b)) + exn + exn)))))] + [mod-h (wasm-sandbox-load bv)] + [inst (wasm-sandbox-instantiate mod-h)]) + (wasm-sandbox-free inst) + (wasm-sandbox-free-module mod-h) + #f)) ;; Should not reach here + #t) + +;;; ============================================================ +;;; Section 9: Multi-arg arithmetic in wasmi +;;; ============================================================ +(printf "~%--- Section 9: Multi-arg arithmetic in wasmi ---~%") + +;; Basic multi-arg + at the compile-program level (raw i32) +(test "multi-arg addition (3 operands) in wasmi" + (let* ([bv (compile-program + '((define (add3 a b c) + (+ (+ a b) c))))] + [mod-h (wasm-sandbox-load bv)] + [inst (wasm-sandbox-instantiate mod-h)]) + (let ([r (wasm-sandbox-call inst "add3" 10 20 30)]) + (wasm-sandbox-free inst) + (wasm-sandbox-free-module mod-h) + r)) + 60) + +(test "multi-arg multiply (3 operands) in wasmi" + (let* ([bv (compile-program + '((define (mul3 a b c) + (* (* a b) c))))] + [mod-h (wasm-sandbox-load bv)] + [inst (wasm-sandbox-instantiate mod-h)]) + (let ([r (wasm-sandbox-call inst "mul3" 2 3 7)]) + (wasm-sandbox-free inst) + (wasm-sandbox-free-module mod-h) + r)) + 42) + +;;; ============================================================ +;;; Section 10: Display/log output via hosted instance +;;; ============================================================ +(printf "~%--- Section 10: Display/log output in wasmi ---~%") + +;; Helper: compile full runtime + display forms + user code for hosted execution. +;; Import signatures MUST match what jerboa_wasm_instance_new_hosted provides. +(define (compile-scheme-hosted user-forms) + (compile-program + (append + value-memory-forms + value-global-forms + value-tag-forms + value-predicate-forms + value-accessor-forms + value-constructor-forms + gc-all-forms + ;; WASI host imports + '((define-import "wasi_snapshot_preview1" fd_write (i32 i32 i32 i32) (i32)) + (define-import "wasi_snapshot_preview1" fd_read (i32 i32 i32 i32) (i32)) + (define-import "wasi_snapshot_preview1" clock_time_get (i32 i64 i32) (i32)) + (define-import "wasi_snapshot_preview1" random_get (i32 i32) (i32)) + (define-import "wasi_snapshot_preview1" proc_exit (i32) ()) + ;; DNS host imports + (define-import "dns" log_message (i32 i32 i32) (i32)) + (define-import "dns" get_time_ms () (i32)) + (define-import "dns" recv_packet (i32 i32) (i32)) + (define-import "dns" send_packet (i32 i32 i32 i32) (i32)) + (define-import "dns" cdb_open (i32 i32) (i32)) + (define-import "dns" cdb_find (i32 i32 i32 i32 i32) (i32)) + (define-import "dns" cdb_close (i32) (i32))) + runtime-all-forms + runtime-display-forms + user-forms))) + +;; Display a fixnum: should log the decimal string via log_message +(test "scheme-display fixnum logs correctly" + (let* ([bv (compile-scheme-hosted + '((define (test-display-num n) + (scheme-display (tag-fixnum n)) + 0)))] + [mod-h (wasm-sandbox-load bv)] + [inst (wasm-sandbox-instantiate-hosted mod-h 'fuel: 10000000)]) + (wasm-sandbox-call inst "test-display-num" 42) + (let ([log (wasm-sandbox-get-log inst)]) + (wasm-sandbox-free inst) + (wasm-sandbox-free-module mod-h) + (and (string-contains log "42") #t))) + #t) + +;; Display #t: should log "#t" +(test "scheme-display boolean #t logs correctly" + (let* ([bv (compile-scheme-hosted + '((define (test-display-true) + (scheme-display 2) ;; IMM-TRUE = 2 + 0)))] + [mod-h (wasm-sandbox-load bv)] + [inst (wasm-sandbox-instantiate-hosted mod-h 'fuel: 10000000)]) + (wasm-sandbox-call inst "test-display-true") + (let ([log (wasm-sandbox-get-log inst)]) + (wasm-sandbox-free inst) + (wasm-sandbox-free-module mod-h) + (and (string-contains log "#t") #t))) + #t) + +;; Display #f: should log "#f" +(test "scheme-display boolean #f logs correctly" + (let* ([bv (compile-scheme-hosted + '((define (test-display-false) + (scheme-display 0) ;; IMM-FALSE = 0 + 0)))] + [mod-h (wasm-sandbox-load bv)] + [inst (wasm-sandbox-instantiate-hosted mod-h 'fuel: 10000000)]) + (wasm-sandbox-call inst "test-display-false") + (let ([log (wasm-sandbox-get-log inst)]) + (wasm-sandbox-free inst) + (wasm-sandbox-free-module mod-h) + (and (string-contains log "#f") #t))) + #t) + +;; Newline: scheme-newline should log a newline character +(test "scheme-newline logs newline" + (let* ([bv (compile-scheme-hosted + '((define (test-newline) + (scheme-newline) + 0)))] + [mod-h (wasm-sandbox-load bv)] + [inst (wasm-sandbox-instantiate-hosted mod-h 'fuel: 10000000)]) + (wasm-sandbox-call inst "test-newline") + (let ([log (wasm-sandbox-get-log inst)]) + (wasm-sandbox-free inst) + (wasm-sandbox-free-module mod-h) + ;; The log should contain something (the newline byte) + (> (string-length log) 0))) + #t) + +;; Negative number display +(test "scheme-display negative fixnum logs correctly" + (let* ([bv (compile-scheme-hosted + '((define (test-display-neg n) + (scheme-display (tag-fixnum n)) + 0)))] + [mod-h (wasm-sandbox-load bv)] + [inst (wasm-sandbox-instantiate-hosted mod-h 'fuel: 10000000)]) + (wasm-sandbox-call inst "test-display-neg" -7) + (let ([log (wasm-sandbox-get-log inst)]) + (wasm-sandbox-free inst) + (wasm-sandbox-free-module mod-h) + (and (string-contains log "-7") #t))) + #t) + +;;; ============================================================ ;;; Summary ;;; ============================================================