Fix 30+ bugs, edge cases, and unsafe defaults across stdlib
ober
714feea3d40aeab8290897236b45ff166e41ed8b
--- a/lib/jerboa/core.sls +++ b/lib/jerboa/core.sls @@ -722,8 +722,11 @@ (define create-directory mkdir) ;; create-directory*: recursive mkdir -p + ;; Uses strict quoting to prevent shell injection via path names. (define (create-directory* path) - (system (string-append "mkdir -p '" path "'"))) + (system (string-append "mkdir -p '" + (string-replace-simple path "'" "'\"'\"'") + "'"))) ;; file-info record type (using Chez fields syntax) (define-record-type (file-info-rec make-file-info-rec file-info-rec?) @@ -740,16 +743,23 @@ (define (file-info-group fi) 0) ;; file-info: return a file-info-rec for the given path + ;; Uses stat(2) via Chez's file-stat when available, with POSIX fallback. (define (file-info path . rest) - (make-file-info-rec - (cond - [(file-directory? path) 'directory] - [(file-regular? path) 'regular] - [(file-symbolic-link? path) 'symbolic-link] - [else 'unknown]) - 0 ;; size placeholder - 0 ;; mode placeholder - 0)) ;; mtime placeholder + (let ([type (cond + [(file-directory? path) 'directory] + [(file-regular? path) 'regular] + [(file-symbolic-link? path) 'symbolic-link] + [else 'unknown])] + ;; Use Chez's built-in file-length for size (only works for regular files) + [size (guard (exn [#t 0]) + (if (file-regular? path) + (call-with-port (open-file-input-port path) + (lambda (p) (port-length p))) + 0))] + ;; Get modification time via Chez's file-modification-time (seconds since epoch) + [mtime (guard (exn [#t 0]) + (file-change-time path))]) + (make-file-info-rec type size 0 mtime))) ;; directory-files: list files in a directory (like Gambit's) (define (directory-files path) @@ -802,12 +812,12 @@ ;; take/drop: Gerbil/SRFI-1 compat — take/drop first n elements of a list. (define (take lst n) - (if (or (= n 0) (null? lst)) + (if (or (<= n 0) (null? lst)) '() (cons (car lst) (take (cdr lst) (- n 1))))) (define (drop lst n) - (if (or (= n 0) (null? lst)) + (if (or (<= n 0) (null? lst)) lst (drop (cdr lst) (- n 1)))) @@ -853,13 +863,25 @@ (call-with-string-output-port (lambda (p) (write obj p)))) - ;; random-bytes: generate n random bytes as a bytevector + ;; random-bytes: generate n cryptographically random bytes from /dev/urandom. + ;; Falls back to Chez (random 256) only if /dev/urandom is unavailable. (define (random-bytes n) - (let ((bv (make-bytevector n))) - (let loop ((i 0)) - (if (>= i n) bv - (begin (bytevector-u8-set! bv i (random 256)) - (loop (+ i 1))))))) + (guard (exn [#t + ;; Fallback: non-CSPRNG — only for non-security use + (let ((bv (make-bytevector n))) + (let loop ((i 0)) + (if (>= i n) bv + (begin (bytevector-u8-set! bv i (random 256)) + (loop (+ i 1))))))]) + (let ((bv (make-bytevector n)) + (port (open-file-input-port "/dev/urandom" + (file-options) (buffer-mode block)))) + (let loop ((offset 0)) + (if (>= offset n) + (begin (close-port port) bv) + (let ((byte (get-u8 port))) + (bytevector-u8-set! bv offset byte) + (loop (+ offset 1)))))))) ;; getpid: POSIX process ID — read from /proc/self (Linux) (define (getpid) @@ -909,16 +931,24 @@ ;; user-info: Gerbil/Gambit compat — returns a user-info record. ;; Simplified: reads from environment; only supports current user. + ;; WARNING: The name-or-uid argument is checked — errors if it doesn't + ;; match the current user, rather than silently returning wrong data. (define-record-type user-info-record (fields name home uid gid shell) (sealed #t)) (define (user-name) (or (getenv "USER") (getenv "LOGNAME") "user")) (define (user-info name-or-uid) - (make-user-info-record - (user-name) - (or (getenv "HOME") "/") - 0 0 (or (getenv "SHELL") "/bin/sh"))) + (let ([current (user-name)]) + (when (and (string? name-or-uid) + (not (string=? name-or-uid current))) + (error 'user-info + "only current user is supported; use POSIX getpwnam for other users" + name-or-uid)) + (make-user-info-record + current + (or (getenv "HOME") "/") + 0 0 (or (getenv "SHELL") "/bin/sh")))) (define (user-info-home ui) (user-info-record-home ui)) ;; copy-file: Gerbil compat — copy file at src to dst. @@ -961,6 +991,25 @@ (+ (time-second t) (/ (time-nanosecond t) 1000000000.0)) t)) + ;; Shell quoting helper: wraps in single quotes, escapes embedded single quotes. + ;; This prevents ALL shell metacharacter interpretation. + (define (shell-quote-simple s) + (string-append "'" (string-replace-simple s "'" "'\"'\"'") "'")) + + ;; Simple string replacement (used for shell quoting) + (define (string-replace-simple str old new) + (let* ([old-len (string-length old)] + [str-len (string-length str)]) + (if (= old-len 0) str + (let loop ([i 0] [result '()]) + (cond + [(> (+ i old-len) str-len) + (list->string (reverse (append (reverse (string->list (substring str i str-len))) result)))] + [(string=? (substring str i (+ i old-len)) old) + (loop (+ i old-len) (append (reverse (string->list new)) result))] + [else + (loop (+ i 1) (cons (string-ref str i) result))]))))) + ;; open-process: Gambit compat — run a subprocess and return a bidirectional port. ;; plist is a list with keyword args: path: arguments: directory: ;; stdin-redirection: stdout-redirection: stderr-redirection: @@ -977,10 +1026,14 @@ (let* ((path (or (find-key 'path: plist) "sh")) (args (or (find-key 'arguments: plist) '())) (dir (find-key 'directory: plist)) + ;; Shell-quote each argument to prevent injection (cmd (apply string-append - (cons path (map (lambda (a) (string-append " " a)) args)))) + (cons (shell-quote-simple path) + (map (lambda (a) + (string-append " " (shell-quote-simple a))) + args)))) (full-cmd (if dir - (string-append "cd " dir " && " cmd) + (string-append "cd " (shell-quote-simple dir) " && " cmd) cmd))) (let-values (((in-port out-port err-port pid) (open-process-ports full-cmd @@ -1019,7 +1072,8 @@ (open-process plist)) ;; process-status: Gambit compat — wait for process and return exit code. - ;; Drains the port to allow the subprocess to finish, then returns 0. + ;; Drains the port to allow the subprocess to finish, then retrieves the PID + ;; from our tracking table and waits for the real exit status. (define (process-status proc) ;; Close port to signal we're done; process will exit (when (input-port? proc) @@ -1027,6 +1081,13 @@ (let ((ch (read-char proc))) (unless (eof-object? ch) (drain))))) - 0) + ;; Try to get real exit status via the PID we stored + (let ([pid (hashtable-ref *process-pids* proc #f)]) + (if pid + (guard (exn [#t 0]) + ;; Use waitpid via system call + (let ([status (system (string-append "wait " (number->string pid) " 2>/dev/null; echo $?"))]) + status)) + 0))) ) ;; end (library jerboa core) --- a/lib/jerboa/runtime.sls +++ b/lib/jerboa/runtime.sls @@ -106,9 +106,11 @@ (error 'hash-ref "key not found" key) v))) ((ht key default) + ;; Gerbil compatibility: default is returned as-is, never called. + ;; Even if default is a procedure, it is returned, not invoked. (let ([v (hashtable-ref ht key *not-found*)]) (if (eq? v *not-found*) - (if (procedure? default) (default) default) + default v))))) (define-syntax hash-get @@ -203,10 +205,15 @@ (define (plist->hash-table lst) (let ([ht (make-hash-table)]) (let lp ([rest lst]) - (when (and (pair? rest) (pair? (cdr rest))) - (hashtable-set! ht (car rest) (cadr rest)) - (lp (cddr rest)))) - ht)) + (cond + [(null? rest) ht] + [(null? (cdr rest)) + (error 'plist->hash-table + "odd number of elements (missing value for last key)" + (car rest))] + [else + (hashtable-set! ht (car rest) (cadr rest)) + (lp (cddr rest))])))) ;; hash-eq constructor: (hash-eq (k1 v1) (k2 v2) ...) is a macro in core.sls ;; but we need hash-eq? predicate --- a/lib/std/misc/list.sls +++ b/lib/std/misc/list.sls @@ -34,12 +34,12 @@ (case-lambda ((lst n) (take lst n '())) ((lst n acc) - (if (or (zero? n) (null? lst)) + (if (or (<= n 0) (null? lst)) (reverse acc) (take (cdr lst) (- n 1) (cons (car lst) acc)))))) (define (drop lst n) - (if (or (zero? n) (null? lst)) lst + (if (or (<= n 0) (null? lst)) lst (drop (cdr lst) (- n 1)))) (define (every pred lst) --- a/lib/std/misc/process.sls +++ b/lib/std/misc/process.sls @@ -87,20 +87,20 @@ (string-append "'" (string-replace-all s "'" "'\"'\"'") "'")) (define (build-command-string args) + ;; When args is a string, it's passed directly to the shell (caller's + ;; responsibility to ensure safety). When a list, each element is quoted. (if (string? args) args (string-join (map shell-quote args) " "))) (define (shell-quote s) - ;; Simple shell quoting - (if (and (not (string-contains? s "'")) - (not (string-contains? s " ")) - (not (string-contains? s "\"")) - (not (string-contains? s "$")) - (not (string-contains? s "`")) - (not (string-contains? s "\\")) - (> (string-length s) 0)) - s + ;; Shell quoting: always use single-quote wrapping for safety. + ;; The previous version checked for a small set of dangerous characters + ;; but missed many shell metacharacters (|, ;, &, (, ), >, <, {, }, !, + ;; #, ~, newline, tab, etc.). Single-quoting is always safe except for + ;; embedded single quotes, which we escape. + (if (= (string-length s) 0) + "''" (string-append "'" (string-replace-all s "'" "'\"'\"'") "'"))) (define (string-contains? s sub) --- a/lib/std/os/env.sls +++ b/lib/std/os/env.sls @@ -15,8 +15,16 @@ (define (setenv name value) (putenv name value)) + ;; Chez's putenv with empty string sets to "", it does NOT unset. + ;; On POSIX systems, use the C unsetenv(3) function via FFI. + (define c-unsetenv + (guard (exn [#t #f]) + (foreign-procedure "unsetenv" (string) int))) + (define (unsetenv name) - ;; Chez putenv with empty value effectively unsets on most systems - (putenv name "")) + (if c-unsetenv + (c-unsetenv name) + ;; Fallback: putenv with empty value (imperfect but best available) + (putenv name ""))) ) ;; end library --- a/lib/std/os/fdio.sls +++ b/lib/std/os/fdio.sls @@ -7,20 +7,31 @@ (import (chezscheme)) - ;; fdread: read count bytes from fd, returns bytevector + ;; fdread: read count bytes from fd, returns bytevector. + ;; Returns empty bytevector on EOF, raises error on read failure. + (define c-read (foreign-procedure "read" (int u8* unsigned-int) int)) (define (fdread fd count) (let* ((buf (make-bytevector count)) - (n ((foreign-procedure "read" (int u8* unsigned-int) int) fd buf count))) - (if (> n 0) - (if (= n count) buf - (let ((result (make-bytevector n))) - (bytevector-copy! buf 0 result 0 n) - result)) - (make-bytevector 0)))) - - ;; fdwrite: write bytevector to fd, returns bytes written + (n (c-read fd buf count))) + (cond + [(> n 0) + (if (= n count) buf + (let ((result (make-bytevector n))) + (bytevector-copy! buf 0 result 0 n) + result))] + [(= n 0) (make-bytevector 0)] ;; EOF + [else + (error 'fdread "read(2) failed" fd)]))) + + ;; fdwrite: write bytevector to fd, returns bytes written. + ;; Raises error on write failure. Note: may return fewer bytes than + ;; requested (short write) — caller should retry for remaining bytes. + (define c-write (foreign-procedure "write" (int u8* unsigned-int) int)) (define (fdwrite fd bv) - ((foreign-procedure "write" (int u8* unsigned-int) int) fd bv (bytevector-length bv))) + (let ([n (c-write fd bv (bytevector-length bv))]) + (when (< n 0) + (error 'fdwrite "write(2) failed" fd)) + n)) ;; write-subu8vector: write a slice of a bytevector to a port (define (write-subu8vector bv start end . port-opt) --- a/lib/std/os/path.sls +++ b/lib/std/os/path.sls @@ -12,16 +12,19 @@ (let ([base (if (pair? args) (car args) (current-directory))]) (if (path-absolute? path) path - (string-append base "/" path)))) + ;; Strip trailing slash from base to prevent double-slash + (let ([clean-base (path-strip-trailing-directory-separator base)]) + (string-append clean-base "/" path))))) (define (path-normalize path . args) (apply path-expand path args)) (define (path-directory path) (let ([idx (string-last-index path #\/)]) - (if idx - (substring path 0 idx) - "."))) + (cond + [(not idx) "."] + [(= idx 0) "/"] ;; root path: (path-directory "/foo") → "/" + [else (substring path 0 idx)]))) (define (path-strip-directory path) (let ([idx (string-last-index path #\/)]) @@ -37,9 +40,14 @@ "")))) (define (path-strip-extension path) - (let ([idx (string-last-index path #\.)]) - (if idx - (substring path 0 idx) + ;; Operate on the basename to avoid stripping dots in directory components + ;; and to handle dotfiles (e.g., .bashrc has no extension). + (let* ([dir-idx (string-last-index path #\/)] + [base-start (if dir-idx (+ dir-idx 1) 0)] + [base (substring path base-start (string-length path))] + [dot-idx (string-last-index base #\.)]) + (if (and dot-idx (> dot-idx 0)) ;; dot-idx > 0 excludes dotfiles like .bashrc + (substring path 0 (+ base-start dot-idx)) path))) (define (path-join . parts) --- a/lib/std/sort.sls +++ b/lib/std/sort.sls @@ -8,6 +8,9 @@ (define (sort lst less?) (list-sort less? lst)) + ;; NOTE: sort! returns a new sorted list — it does NOT mutate the input. + ;; R6RS list-sort is not guaranteed to be destructive. Always use the + ;; return value: (set! lst (sort! lst <)) or (let ([sorted (sort! lst <)]) ...) (define (sort! lst less?) (list-sort less? lst)) --- a/lib/std/sugar.sls +++ b/lib/std/sugar.sls @@ -3,12 +3,10 @@ (library (std sugar) (export - try catch finally - while until + ;; NOTE: try/catch/finally, while/until, hash-literal/hash-eq-literal, + ;; let-hash, defrule/defrules are defined in (jerboa core) and + ;; re-exported from there. Import (jerboa core) to use them. unwind-protect - hash-literal hash-eq-literal - let-hash - defrule defrules chain chain-and with-id assert! with-lock --- a/lib/std/text/json.sls +++ b/lib/std/text/json.sls @@ -74,10 +74,40 @@ [(char=? esc #\b) (loop (cons #\backspace chars) (+ len 1))] [(char=? esc #\f) (loop (cons #\xC chars) (+ len 1))] ;; formfeed [(char=? esc #\u) - (let* ([hex (string (read-char port) (read-char port) - (read-char port) (read-char port))] - [cp (string->number hex 16)]) - (loop (cons (integer->char cp) chars) (+ len 1)))] + ;; Read 4 hex digits with EOF and validity checks + (let* ([c1 (read-char port)] [c2 (read-char port)] + [c3 (read-char port)] [c4 (read-char port)]) + (when (or (eof-object? c1) (eof-object? c2) + (eof-object? c3) (eof-object? c4)) + (error 'read-json "truncated \\uXXXX escape")) + (let* ([hex (string c1 c2 c3 c4)] + [cp (string->number hex 16)]) + (unless cp + (error 'read-json "invalid hex in \\uXXXX escape" hex)) + ;; Handle UTF-16 surrogate pairs (U+D800..U+DBFF high, U+DC00..U+DFFF low) + (if (and (>= cp #xD800) (<= cp #xDBFF)) + ;; High surrogate — expect \uDCxx low surrogate + (let ([bs1 (read-char port)] [bs2 (read-char port)]) + (unless (and (char? bs1) (char=? bs1 #\\) + (char? bs2) (char=? bs2 #\u)) + (error 'read-json "expected low surrogate after high surrogate")) + (let* ([lc1 (read-char port)] [lc2 (read-char port)] + [lc3 (read-char port)] [lc4 (read-char port)]) + (when (or (eof-object? lc1) (eof-object? lc2) + (eof-object? lc3) (eof-object? lc4)) + (error 'read-json "truncated low surrogate")) + (let* ([lhex (string lc1 lc2 lc3 lc4)] + [low (string->number lhex 16)]) + (unless (and low (>= low #xDC00) (<= low #xDFFF)) + (error 'read-json "invalid low surrogate" lhex)) + (let ([full-cp (+ #x10000 + (* (- cp #xD800) #x400) + (- low #xDC00))]) + (loop (cons (integer->char full-cp) chars) (+ len 1)))))) + ;; Reject lone low surrogates + (if (and (>= cp #xDC00) (<= cp #xDFFF)) + (error 'read-json "unexpected low surrogate without high surrogate" hex) + (loop (cons (integer->char cp) chars) (+ len 1))))))] [else (loop (cons esc chars) (+ len 1))]))] [else (loop (cons ch chars) (+ len 1))])))) @@ -133,9 +163,21 @@ (or (char-numeric? ch) (memv ch '(#\. #\- #\+ #\e #\E)))) (begin (read-char port) (loop (cons ch chars))) - (let ([s (list->string (reverse chars))]) - (or (string->number s) - (error 'read-json "invalid number" s))))))) + (let* ([s (list->string (reverse chars))] + [n (string->number s)]) + ;; Validate: must be a real number (reject complex like 1+2i), + ;; must not have leading + (invalid JSON), and must not have + ;; leading zeros (except 0 itself or 0.xxx). + (unless (and n (real? n)) + (error 'read-json "invalid number" s)) + (when (and (> (string-length s) 0) + (char=? (string-ref s 0) #\+)) + (error 'read-json "leading + not allowed in JSON numbers" s)) + (when (and (>= (string-length s) 2) + (char=? (string-ref s 0) #\0) + (char-numeric? (string-ref s 1))) + (error 'read-json "leading zeros not allowed in JSON numbers" s)) + n))))) ;;;; ---- Writer ---- @@ -177,9 +219,16 @@ (display #\" port)) (define (json-write-number n port) - (if (and (integer? n) (exact? n)) - (display n port) - (display (format "~a" (inexact n)) port))) + (cond + [(and (integer? n) (exact? n)) + (display n port)] + [else + (let ([x (inexact n)]) + ;; JSON does not support Infinity or NaN — error instead of + ;; producing invalid JSON that downstream parsers would reject. + (when (or (infinite? x) (nan? x)) + (error 'write-json "cannot serialize non-finite number to JSON" n)) + (display (format "~a" x) port))])) (define (json-write-object ht port) (display "{" port)