Security hardening and performance: FFI, CSPRNG, shell-injection fixes
ober
9d059f92a8192a7d1751fc5a0601059610305022
--- a/lib/jerboa-coreutils/b2sum.sls +++ b/lib/jerboa-coreutils/b2sum.sls @@ -14,15 +14,6 @@ (jerboa-coreutils common) (jerboa-coreutils common version)) - (def (shell-quote str) - (string-append "'" (let loop ((i 0) (acc '())) - (if (>= i (string-length str)) - (list->string (reverse acc)) - (let ((c (string-ref str i))) - (if (eqv? c #\') - (loop (+ i 1) (append (reverse (string->list "'\\''")) acc)) - (loop (+ i 1) (cons c acc)))))) "'")) - (def (string-index-of str ch) (let loop ((i 0)) (cond --- a/lib/jerboa-coreutils/chmod.sls +++ b/lib/jerboa-coreutils/chmod.sls @@ -19,32 +19,12 @@ (define ffi-chmod (foreign-procedure "chmod" (string int) int)) + (define ffi-lstat-mode-c (foreign-procedure "coreutils_lstat_mode" (string) int)) + (define ffi-lstat-mode - (let ((lstat-fn (foreign-procedure "lstat" (string u8* int) int))) - (lambda (path) - (let ((buf (make-bytevector 256 0))) - (let ((rc (lstat-fn path buf 256))) - (if (< rc 0) -1 - ;; st_mode is at different offsets depending on platform - ;; Use the system stat command as fallback - (let ((mode-str - (with-catch - (lambda (e) #f) - (lambda () - (let-values (((to-stdin from-stdout from-stderr pid) - (open-process-ports - (string-append "stat -c '%a' " path) - (buffer-mode block) - (native-transcoder)))) - (close-port to-stdin) - (let ((result (get-line from-stdout))) - (close-port from-stdout) - (close-port from-stderr) - result)))))) - (if (and mode-str (not (eof-object? mode-str))) - (let ((n (string->number mode-str 8))) - (if n n -1)) - -1)))))))) + (lambda (path) + (ffi-lstat-mode-c path))) + (define ffi-stat-isdir (lambda (path) --- a/lib/jerboa-coreutils/common.sls +++ b/lib/jerboa-coreutils/common.sls @@ -8,6 +8,12 @@ warn try-help split-long-opts + shell-quote + string-contains? + secure-random-bytes + secure-random-integer + safe-path-join + path-within-base? EXIT_SUCCESS EXIT_FAILURE) @@ -62,4 +68,143 @@ ((char=? (string-ref str i) #\=) i) (else (loop (+ i 1)))))) + ;; ========== Shell quoting ========== + ;; Single-quote a string for safe shell interpolation. + ;; The only character that needs escaping inside single quotes is + ;; the single quote itself: end quote, escaped quote, restart quote. + (define (shell-quote str) + (string-append "'" (let loop ((i 0) (acc '())) + (if (>= i (string-length str)) + (list->string (reverse acc)) + (let ((c (string-ref str i))) + (if (eqv? c #\') + (loop (+ i 1) (append (reverse (string->list "'\\''")) acc)) + (loop (+ i 1) (cons c acc)))))) "'")) + + ;; ========== String utilities ========== + (define (string-contains? str sub) + (let ((slen (string-length str)) + (sublen (string-length sub))) + (if (> sublen slen) #f + (let loop ((i 0)) + (cond + ((> (+ i sublen) slen) #f) + ((string=? (substring str i (+ i sublen)) sub) #t) + (else (loop (+ i 1)))))))) + + ;; ========== CSPRNG ========== + ;; Read cryptographically secure random bytes from /dev/urandom. + ;; This replaces insecure (random-integer N) for security-sensitive + ;; uses like mktemp, shred, and shuf. + (define (secure-random-bytes n) + (let ((port (open-file-input-port "/dev/urandom")) + (buf (make-bytevector n))) + (dynamic-wind + (lambda () (void)) + (lambda () + (let loop ((offset 0)) + (when (< offset n) + (let ((got (get-bytevector-n! port buf offset (- n offset)))) + (when (and (fixnum? got) (> got 0)) + (loop (+ offset got)))))) + buf) + (lambda () (close-port port))))) + + ;; Return a cryptographically secure random integer in [0, bound). + ;; Uses rejection sampling to avoid modulo bias. + (define (secure-random-integer bound) + (if (<= bound 1) + 0 + (if (<= bound 256) + ;; Single-byte fast path with rejection sampling + (let ((limit (- 256 (modulo 256 bound)))) + (let loop () + (let* ((buf (secure-random-bytes 1)) + (val (bytevector-u8-ref buf 0))) + (if (< val limit) + (modulo val bound) + (loop))))) + ;; Multi-byte path: use 4 bytes for up to 2^32 + (let ((limit (- (expt 2 32) (modulo (expt 2 32) bound)))) + (let loop () + (let* ((buf (secure-random-bytes 4)) + (val (+ (bytevector-u8-ref buf 0) + (* 256 (bytevector-u8-ref buf 1)) + (* 65536 (bytevector-u8-ref buf 2)) + (* 16777216 (bytevector-u8-ref buf 3))))) + (if (< val limit) + (modulo val bound) + (loop)))))))) + + ;; ========== Path safety ========== + ;; Check if a path stays within a base directory. + ;; Rejects NUL bytes and ".." traversal that escapes the base. + (define (path-within-base? path base) + ;; Reject NUL bytes + (when (string-contains? path (string #\nul)) + (error 'path-within-base? "path contains NUL byte")) + ;; Normalize: split on /, resolve . and .., check prefix + (let* ((base-parts (normalize-path-parts (split-path base))) + (path-parts (normalize-path-parts (split-path path))) + (blen (length base-parts))) + ;; path-parts must start with all of base-parts + (and (>= (length path-parts) blen) + (let loop ((bp base-parts) (pp path-parts)) + (cond + ((null? bp) #t) + ((string=? (car bp) (car pp)) + (loop (cdr bp) (cdr pp))) + (else #f)))))) + + ;; Join base + relative path, rejecting traversal escapes. + ;; Returns the joined path or #f if the result would escape base. + (define (safe-path-join base relative) + ;; Reject NUL bytes + (when (string-contains? relative (string #\nul)) + (error 'safe-path-join "path contains NUL byte")) + ;; Reject absolute relative paths + (when (and (> (string-length relative) 0) + (eqv? (string-ref relative 0) #\/)) + (error 'safe-path-join "relative path must not be absolute")) + (let* ((joined (string-append base "/" relative)) + (base-parts (normalize-path-parts (split-path base))) + (joined-parts (normalize-path-parts (split-path joined))) + (blen (length base-parts))) + (if (and (>= (length joined-parts) blen) + (let loop ((bp base-parts) (jp joined-parts)) + (cond + ((null? bp) #t) + ((string=? (car bp) (car jp)) + (loop (cdr bp) (cdr jp))) + (else #f)))) + joined + #f))) + + ;; Split a path by / + (define (split-path path) + (let ((len (string-length path))) + (let loop ((i 0) (start 0) (acc '())) + (cond + ((>= i len) + (reverse (if (> i start) + (cons (substring path start i) acc) + acc))) + ((eqv? (string-ref path i) #\/) + (loop (+ i 1) (+ i 1) + (if (> i start) + (cons (substring path start i) acc) + acc))) + (else (loop (+ i 1) start acc)))))) + + ;; Normalize path parts: resolve "." and ".." + (define (normalize-path-parts parts) + (let loop ((rest parts) (acc '())) + (cond + ((null? rest) (reverse acc)) + ((string=? (car rest) ".") (loop (cdr rest) acc)) + ((string=? (car rest) "..") + (loop (cdr rest) + (if (null? acc) '() (cdr acc)))) + (else (loop (cdr rest) (cons (car rest) acc)))))) + ) ;; end library --- a/lib/jerboa-coreutils/cp.sls +++ b/lib/jerboa-coreutils/cp.sls @@ -21,81 +21,30 @@ (define ffi-link (foreign-procedure "link" (string string) int)) (define ffi-mkdir (foreign-procedure "mkdir" (string int) int)) (define ffi-unlink (foreign-procedure "unlink" (string) int)) + (define ffi-cp-lstat (foreign-procedure "coreutils_cp_lstat" (string) int)) + (define ffi-cp-stat-get (foreign-procedure "coreutils_cp_stat_get" (int) long)) + (define ffi-cp-readlink (foreign-procedure "coreutils_cp_readlink" (string) string)) + (define ffi-cp-stat-atime (foreign-procedure "coreutils_stat_atime" (string) long)) + (define ffi-cp-stat-mtime (foreign-procedure "coreutils_stat_mtime" (string) long)) + (define ffi-utime (foreign-procedure "coreutils_utime" (string long long) int)) + (define ffi-stat-mode (foreign-procedure "coreutils_stat_get_mode" (string) int)) (define *exit-code* 0) - ;; Get file type via stat command: 'regular, 'directory, 'symlink, 'other, or #f + ;; Get file type via lstat FFI: 'regular, 'directory, 'symlink, 'other, or #f (def (get-file-type path) - (with-catch - (lambda (e) #f) - (lambda () - (let ((cmd (string-append "stat -c '%F' " (shell-quote path) " 2>/dev/null"))) - (let-values (((to-stdin from-stdout from-stderr pid) - (open-process-ports cmd (buffer-mode block) (native-transcoder)))) - (close-port to-stdin) - (let ((line (get-line from-stdout))) - (close-port from-stdout) - (close-port from-stderr) - (if (or (not line) (eof-object? line)) - #f - (cond - ((string-contains? line "symbolic link") 'symlink) - ((string-contains? line "directory") 'directory) - ((string-contains? line "regular") 'regular) - (else 'other))))))))) - - ;; Get file type via lstat (does not follow symlinks) - (def (get-lfile-type path) - (with-catch - (lambda (e) #f) - (lambda () - (let ((cmd (string-append "stat -L -c '%F' " (shell-quote path) " 2>/dev/null"))) - (let-values (((to-stdin from-stdout from-stderr pid) - (open-process-ports cmd (buffer-mode block) (native-transcoder)))) - (close-port to-stdin) - (let ((line (get-line from-stdout))) - (close-port from-stdout) - (close-port from-stderr) - (if (or (not line) (eof-object? line)) - ;; Fall back to non-L stat for the raw type - (get-file-type path) - (cond - ((string-contains? line "symbolic link") 'symlink) - ((string-contains? line "directory") 'directory) - ((string-contains? line "regular") 'regular) - (else 'other))))))))) - - (def (string-contains? str sub) - (let ((slen (string-length str)) - (sublen (string-length sub))) - (if (> sublen slen) #f - (let loop ((i 0)) + (let ((rc (ffi-cp-lstat path))) + (if (< rc 0) + #f + (let ((type-code (ffi-cp-stat-get 7))) (cond - ((> (+ i sublen) slen) #f) - ((string=? (substring str i (+ i sublen)) sub) #t) - (else (loop (+ i 1)))))))) - - (def (shell-quote str) - (string-append "'" (let loop ((i 0) (acc '())) - (if (>= i (string-length str)) - (list->string (reverse acc)) - (let ((c (string-ref str i))) - (if (eqv? c #\') - (loop (+ i 1) (append (reverse (string->list "'\\''")) acc)) - (loop (+ i 1) (cons c acc)))))) "'")) + ((= type-code 0) 'regular) + ((= type-code 1) 'directory) + ((= type-code 2) 'symlink) + (else 'other)))))) (def (read-symlink path) - (with-catch - (lambda (e) #f) - (lambda () - (let ((cmd (string-append "readlink " (shell-quote path) " 2>/dev/null"))) - (let-values (((to-stdin from-stdout from-stderr pid) - (open-process-ports cmd (buffer-mode block) (native-transcoder)))) - (close-port to-stdin) - (let ((line (get-line from-stdout))) - (close-port from-stdout) - (close-port from-stderr) - (if (or (not line) (eof-object? line)) #f line))))))) + (ffi-cp-readlink path)) (def (path-basename path) (let loop ((i (- (string-length path) 1))) @@ -109,14 +58,18 @@ (def (copy-file-data src dst) (let ((in (open-file-input-port src)) (out (open-file-output-port dst (file-options no-fail)))) - (let ((buf (make-bytevector 65536))) - (let loop () - (let ((n (get-bytevector-n! in buf 0 65536))) - (unless (eof-object? n) - (put-bytevector out buf 0 n) - (loop))))) - (close-port in) - (close-port out))) + (dynamic-wind + (lambda () (void)) + (lambda () + (let ((buf (make-bytevector 65536))) + (let loop () + (let ((n (get-bytevector-n! in buf 0 65536))) + (unless (eof-object? n) + (put-bytevector out buf 0 n) + (loop)))))) + (lambda () + (close-port in) + (close-port out))))) ;; Confirm overwrite (def (confirm-overwrite dst) @@ -127,19 +80,15 @@ (or (eqv? (string-ref resp 0) #\y) (eqv? (string-ref resp 0) #\Y))))) - ;; Preserve mode and timestamps via cp --preserve + ;; Preserve mode and timestamps via FFI (def (preserve-attributes src dst) - (with-catch - (lambda (e) #t) - (lambda () - (let ((cmd (string-append "chmod --reference=" (shell-quote src) " " (shell-quote dst) - " 2>/dev/null; touch --reference=" (shell-quote src) " " (shell-quote dst) - " 2>/dev/null"))) - (let-values (((to-stdin from-stdout from-stderr pid) - (open-process-ports cmd (buffer-mode block) (native-transcoder)))) - (close-port to-stdin) - (close-port from-stdout) - (close-port from-stderr)))))) + (let ((src-mode (ffi-stat-mode src)) + (src-atime (ffi-cp-stat-atime src)) + (src-mtime (ffi-cp-stat-mtime src))) + (when (>= src-mode 0) + (ffi-chmod dst src-mode)) + (when (and (>= src-atime 0) (>= src-mtime 0)) + (ffi-utime dst src-atime src-mtime)))) ;; Copy a single item (def (copy-one src dst force interactive verbose preserve @@ -224,7 +173,19 @@ (lambda (name) (let ((s (string-append src "/" name)) (d (string-append dst "/" name))) - (copy-one s d force interactive verbose preserve #f #f #t))) + ;; Skip symlinks that point outside the source tree + (let ((s-type (get-file-type s))) + (if (and (eq? s-type 'symlink) + (let ((target (read-symlink s))) + (and target + ;; If symlink target is absolute, check it + (> (string-length target) 0) + (eqv? (string-ref target 0) #\/) + (not (path-within-base? target src))))) + (begin + (warn "skipping symlink '~a' that points outside source tree" s) + (set! *exit-code* 1)) + (copy-one s d force interactive verbose preserve #f #f #t))))) entries)))) (when preserve (preserve-attributes src dst)) --- a/lib/jerboa-coreutils/csplit.sls +++ b/lib/jerboa-coreutils/csplit.sls @@ -84,15 +84,6 @@ (def (string-contains-pattern? line pattern) (line-matches-pattern? line pattern)) - (def (shell-quote str) - (string-append "'" (let loop ((i 0) (acc '())) - (if (>= i (string-length str)) - (list->string (reverse acc)) - (let ((c (string-ref str i))) - (if (eqv? c #\') - (loop (+ i 1) (append (reverse (string->list "'\\''")) acc)) - (loop (+ i 1) (cons c acc)))))) "'")) - ;; Expand patterns: resolve {N} and {*} (def (expand-patterns pat-strings) (let loop ((rest pat-strings) (prev #f) (acc '())) --- a/lib/jerboa-coreutils/date.sls +++ b/lib/jerboa-coreutils/date.sls @@ -38,15 +38,6 @@ (close-port from-stderr) (for-each displayln output))))))) - (def (shell-quote str) - (string-append "'" (let loop ((i 0) (acc '())) - (if (>= i (string-length str)) - (list->string (reverse acc)) - (let ((c (string-ref str i))) - (if (eqv? c #\') - (loop (+ i 1) (append (reverse (string->list "'\\''")) acc)) - (loop (+ i 1) (cons c acc)))))) "'")) - (def (main . args) (parameterize ((program-name "date")) ;; We use a simple manual arg parser to pass args directly to /bin/date --- a/lib/jerboa-coreutils/df.sls +++ b/lib/jerboa-coreutils/df.sls @@ -88,15 +88,6 @@ (list total used avail) #f))))))))))) - (def (shell-quote str) - (string-append "'" (let loop ((i 0) (acc '())) - (if (>= i (string-length str)) - (list->string (reverse acc)) - (let ((c (string-ref str i))) - (if (eqv? c #\') - (loop (+ i 1) (append (reverse (string->list "'\\''")) acc)) - (loop (+ i 1) (cons c acc)))))) "'")) - (def (print-df-header human inode show-type) (if inode (displayln (ljust "Filesystem" 20) --- a/lib/jerboa-coreutils/du.sls +++ b/lib/jerboa-coreutils/du.sls @@ -14,61 +14,18 @@ (jerboa-coreutils common) (jerboa-coreutils common version)) - ;; Get file info via stat command: returns (isdir size blocks islink) or #f - (def (du-stat-info path) - (with-catch - (lambda (e) #f) - (lambda () - (let ((cmd (string-append "stat -c '%F %s %b' " - (shell-quote path) " 2>/dev/null"))) - (let-values (((to-stdin from-stdout from-stderr pid) - (open-process-ports cmd (buffer-mode block) (native-transcoder)))) - (close-port to-stdin) - (let ((line (get-line from-stdout))) - (close-port from-stdout) - (close-port from-stderr) - (if (or (not line) (eof-object? line)) - #f - (let ((parts (string-split-spaces line))) - (if (< (length parts) 3) - #f - (let ((type-str (car parts)) - (size (string->number (list-ref parts (- (length parts) 2)))) - (blocks (string->number (list-ref parts (- (length parts) 1))))) - (list (if (string-contains? type-str "directory") 1 0) - (or size 0) - (or blocks 0) - (if (string-contains? type-str "link") 1 0)))))))))))) - - (def (shell-quote str) - (string-append "'" (let loop ((i 0) (acc '())) - (if (>= i (string-length str)) - (list->string (reverse acc)) - (let ((c (string-ref str i))) - (if (eqv? c #\') - (loop (+ i 1) (append (reverse (string->list "'\\''")) acc)) - (loop (+ i 1) (cons c acc)))))) "'")) - - (def (string-contains? str sub) - (let ((slen (string-length str)) - (sublen (string-length sub))) - (if (> sublen slen) #f - (let loop ((i 0)) - (cond - ((> (+ i sublen) slen) #f) - ((string=? (substring str i (+ i sublen)) sub) #t) - (else (loop (+ i 1)))))))) + (define _load-ffi (begin (load-shared-object #f) (void))) + (define ffi-du-stat (foreign-procedure "coreutils_du_stat" (string int) long)) - (def (string-split-spaces str) - (let loop ((i 0) (start #f) (acc '())) - (cond - ((>= i (string-length str)) - (reverse (if start (cons (substring str start i) acc) acc))) - ((char-whitespace? (string-ref str i)) - (loop (+ i 1) #f - (if start (cons (substring str start i) acc) acc))) - (else - (loop (+ i 1) (or start i) acc))))) + ;; Get file info via FFI stat: returns (isdir size blocks islink) or #f + (def (du-stat-info path) + (let ((isdir (ffi-du-stat path 0))) + (if (< isdir 0) + #f + (let ((size (ffi-du-stat path 1)) + (blocks (ffi-du-stat path 2)) + (islink (ffi-du-stat path 3))) + (list isdir size blocks islink))))) (def (human-readable-size bytes) (cond --- a/lib/jerboa-coreutils/expr.sls +++ b/lib/jerboa-coreutils/expr.sls @@ -273,15 +273,6 @@ (loop (+ i 1) (cons c (cons #\\ acc))) (loop (+ i 1) (cons c acc)))))))) - (def (shell-quote str) - (string-append "'" (let loop ((i 0) (acc '())) - (if (>= i (string-length str)) - (list->string (reverse acc)) - (let ((c (string-ref str i))) - (if (eqv? c #\') - (loop (+ i 1) (append (reverse (string->list "'\\''")) acc)) - (loop (+ i 1) (cons c acc)))))) "'")) - (def (string-contains-substr? str sub) (let ((slen (string-length str)) (sublen (string-length sub))) --- a/lib/jerboa-coreutils/ls.sls +++ b/lib/jerboa-coreutils/ls.sls @@ -18,60 +18,29 @@ (define _load-ffi (begin (load-shared-object #f) (void))) (define ffi-isatty (foreign-procedure "isatty" (int) int)) + (define ffi-lstat (foreign-procedure "coreutils_ls_lstat" (string int) int)) + (define ffi-stat-get (foreign-procedure "coreutils_ls_stat_get" (int) long-long)) + (define ffi-readlink (foreign-procedure "coreutils_ls_readlink" (string) string)) + (define ffi-time-format (foreign-procedure "coreutils_time_format" (long) string)) + (define ffi-uid-to-name (foreign-procedure "coreutils_uid_to_name" (int) string)) + (define ffi-gid-to-name (foreign-procedure "coreutils_gid_to_name" (int) string)) ;;; ========= Data structures ========= ;; Entry: #(name full-path mode nlink uid gid size mtime ino blocks) - ;; We get stat info via system stat command - - (def (shell-quote str) - (string-append "'" (let loop ((i 0) (acc '())) - (if (>= i (string-length str)) - (list->string (reverse acc)) - (let ((c (string-ref str i))) - (if (eqv? c #\') - (loop (+ i 1) (append (reverse (string->list "'\\''")) acc)) - (loop (+ i 1) (cons c acc)))))) "'")) (def (make-entry name full-path follow-links) - (with-catch - (lambda (e) #f) - (lambda () - (let* ((flag (if follow-links "" "-L")) - (cmd (string-append "stat " flag " -c '%f %h %u %g %s %Y %i %b' " - (shell-quote full-path) " 2>/dev/null"))) - (let-values (((to-stdin from-stdout from-stderr pid) - (open-process-ports cmd (buffer-mode block) (native-transcoder)))) - (close-port to-stdin) - (let ((line (get-line from-stdout))) - (close-port from-stdout) - (close-port from-stderr) - (if (or (not line) (eof-object? line)) - #f - (let ((parts (string-split-spaces line))) - (if (< (length parts) 8) - #f - (let ((mode (string->number (list-ref parts 0) 16)) - (nlink (string->number (list-ref parts 1))) - (uid (string->number (list-ref parts 2))) - (gid (string->number (list-ref parts 3))) - (size (string->number (list-ref parts 4))) - (mtime (string->number (list-ref parts 5))) - (ino (string->number (list-ref parts 6))) - (blocks (string->number (list-ref parts 7)))) - (if (and mode nlink uid gid size mtime ino blocks) - (vector name full-path mode nlink uid gid size mtime ino blocks) - #f))))))))))) - - (def (string-split-spaces str) - (let loop ((i 0) (start #f) (acc '())) - (cond - ((>= i (string-length str)) - (reverse (if start (cons (substring str start i) acc) acc))) - ((char-whitespace? (string-ref str i)) - (loop (+ i 1) #f - (if start (cons (substring str start i) acc) acc))) - (else - (loop (+ i 1) (or start i) acc))))) + (let ((rc (ffi-lstat full-path (if follow-links 1 0)))) + (if (< rc 0) + #f + (let ((mode (ffi-stat-get 0)) + (nlink (ffi-stat-get 1)) + (uid (ffi-stat-get 2)) + (gid (ffi-stat-get 3)) + (size (ffi-stat-get 4)) + (mtime (ffi-stat-get 6)) + (ino (ffi-stat-get 8)) + (blocks (ffi-stat-get 9))) + (vector name full-path mode nlink uid gid size mtime ino blocks))))) (def (entry-name e) (vector-ref e 0)) (def (entry-path e) (vector-ref e 1)) @@ -153,60 +122,18 @@ ;;; ========= Symlink target ========= (def (read-symlink path) - (with-catch - (lambda (e) "") - (lambda () - (let ((cmd (string-append "readlink " (shell-quote path) " 2>/dev/null"))) - (let-values (((to-stdin from-stdout from-stderr pid) - (open-process-ports cmd (buffer-mode block) (native-transcoder)))) - (close-port to-stdin) - (let ((line (get-line from-stdout))) - (close-port from-stdout) - (close-port from-stderr) - (if (or (not line) (eof-object? line)) "" line))))))) + (or (ffi-readlink path) "")) ;;; ========= Time formatting ========= (def (format-time mtime) - (with-catch - (lambda (e) "?") - (lambda () - (let ((cmd (string-append "date -d @" (number->string mtime) " '+%b %e %H:%M' 2>/dev/null"))) - (let-values (((to-stdin from-stdout from-stderr pid) - (open-process-ports cmd (buffer-mode block) (native-transcoder)))) - (close-port to-stdin) - (let ((line (get-line from-stdout))) - (close-port from-stdout) - (close-port from-stderr) - (if (or (not line) (eof-object? line)) "?" line))))))) + (or (ffi-time-format mtime) "?")) ;;; ========= User/Group name lookup ========= (def (uid->name uid) - (with-catch - (lambda (e) (number->string uid)) - (lambda () - (let ((cmd (string-append "getent passwd " (number->string uid) " 2>/dev/null | cut -d: -f1"))) - (let-values (((to-stdin from-stdout from-stderr pid) - (open-process-ports cmd (buffer-mode block) (native-transcoder)))) - (close-port to-stdin) - (let ((line (get-line from-stdout))) - (close-port from-stdout) - (close-port from-stderr) - (if (or (not line) (eof-object? line) (string=? line "")) - (number->string uid) line))))))) + (or (ffi-uid-to-name uid) (number->string uid))) (def (gid->name gid) - (with-catch - (lambda (e) (number->string gid)) - (lambda () - (let ((cmd (string-append "getent group " (number->string gid) " 2>/dev/null | cut -d: -f1"))) - (let-values (((to-stdin from-stdout from-stderr pid) - (open-process-ports cmd (buffer-mode block) (native-transcoder)))) - (close-port to-stdin) - (let ((line (get-line from-stdout))) - (close-port from-stdout) - (close-port from-stderr) - (if (or (not line) (eof-object? line) (string=? line "")) - (number->string gid) line))))))) + (or (ffi-gid-to-name gid) (number->string gid))) ;;; ========= Indicator character ========= (def (indicator-char mode) --- a/lib/jerboa-coreutils/mknod.sls +++ b/lib/jerboa-coreutils/mknod.sls @@ -28,23 +28,6 @@ (unless (zero? status) (die "cannot create special file '~a'" name)))) - (def (shell-quote s) - (string-append "'" (string-replace-all s "'" "'\\''") "'")) - - (def (string-replace-all str old new) - (let ((olen (string-length old)) - (out (open-output-string))) - (let loop ((i 0)) - (cond - ((> (+ i olen) (string-length str)) - (display (substring str i (string-length str)) out) - (get-output-string out)) - ((string=? (substring str i (+ i olen)) old) - (display new out) - (loop (+ i olen))) - (else - (write-char (string-ref str i) out) - (loop (+ i 1))))))) (def (parse-mode-str str default) (with-catch --- a/lib/jerboa-coreutils/mktemp.sls +++ b/lib/jerboa-coreutils/mktemp.sls @@ -13,18 +13,11 @@ (jerboa-coreutils common) (jerboa-coreutils common version)) - (def (expand-template template) - ;; Find the X's and replace with random chars - (let* ((len (string-length template)) - (result (string-copy template)) - (chars "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789")) - (let loop ((i 0)) - (when (< i len) - (when (eqv? (string-ref result i) #\X) - (string-set! result i - (string-ref chars (random-integer (string-length chars))))) - (loop (+ i 1)))) - result)) + (define _load-ffi (begin (load-shared-object #f) (void))) + (define ffi-mkstemp (foreign-procedure "coreutils_mkstemp" (string) int)) + (define ffi-mkdtemp (foreign-procedure "coreutils_mkdtemp" (string) int)) + (define ffi-mkstemp-get-path (foreign-procedure "coreutils_mkstemp_get_path" () string)) + (define ffi-close (foreign-procedure "close" (int) int)) (def (count-trailing-x template) (let loop ((i (- (string-length template) 1)) (count 0)) @@ -44,28 +37,25 @@ (x-count (count-trailing-x template))) (when (< x-count 3) (die "too few X's in template '~a'" template)) - ;; Try up to 100 times - (let loop ((attempts 0)) - (when (>= attempts 100) - (die "failed to create ~a after 100 attempts" - (if (hash-get opt 'directory) "directory" "file"))) - (let* ((name (expand-template template)) - (path (if (string-index name #\/) - name - (string-append tmpdir "/" name)))) - (with-catch - (lambda (e) - (loop (+ attempts 1))) - (lambda () - (if (hash-get opt 'directory) - (begin - (create-directory path) - (displayln path)) - (begin - ;; Create file exclusively - (let ((port (open-output-file path))) - (close-port port)) - (displayln path))))))))) + ;; Build full path with XXXXXX suffix for mkstemp/mkdtemp + (let* ((base (substring template 0 (- (string-length template) x-count))) + (mktemp-template (string-append base (make-string (max x-count 6) #\X))) + (full-template (if (string-index mktemp-template #\/) + mktemp-template + (string-append tmpdir "/" mktemp-template)))) + (if (hash-get opt 'directory) + ;; Create directory atomically via mkdtemp(3) + (let ((rc (ffi-mkdtemp full-template))) + (if (< rc 0) + (die "failed to create directory via template '~a'" full-template) + (displayln (ffi-mkstemp-get-path)))) + ;; Create file atomically via mkstemp(3) — O_EXCL guaranteed + (let ((fd (ffi-mkstemp full-template))) + (if (< fd 0) + (die "failed to create file via template '~a'" full-template) + (begin + (ffi-close fd) + (displayln (ffi-mkstemp-get-path))))))))) args 'program: "mktemp" 'help: "Create a temporary file or directory, safely, and print its name." --- a/lib/jerboa-coreutils/nohup.sls +++ b/lib/jerboa-coreutils/nohup.sls @@ -51,23 +51,6 @@ (status (system full-cmd))) (exit status))))))) - (def (shell-quote s) - (string-append "'" (string-replace-all s "'" "'\\''") "'")) - - (def (string-replace-all str old new) - (let ((olen (string-length old)) - (out (open-output-string))) - (let loop ((i 0)) - (cond - ((> (+ i olen) (string-length str)) - (display (substring str i (string-length str)) out) - (get-output-string out)) - ((string=? (substring str i (+ i olen)) old) - (display new out) - (loop (+ i olen))) - (else - (write-char (string-ref str i) out) - (loop (+ i 1))))))) (def (string-join strs sep) (if (null? strs) "" --- a/lib/jerboa-coreutils/pinky.sls +++ b/lib/jerboa-coreutils/pinky.sls @@ -14,15 +14,6 @@ (jerboa-coreutils common) (jerboa-coreutils common version)) - (def (shell-quote str) - (string-append "'" (let loop ((i 0) (acc '())) - (if (>= i (string-length str)) - (list->string (reverse acc)) - (let ((c (string-ref str i))) - (if (eqv? c #\') - (loop (+ i 1) (append (reverse (string->list "'\\''")) acc)) - (loop (+ i 1) (cons c acc)))))) "'")) - (def (run-pinky pinky-args) (with-catch (lambda (e) --- a/lib/jerboa-coreutils/readlink.sls +++ b/lib/jerboa-coreutils/readlink.sls @@ -52,23 +52,6 @@ (close-port from-stderr) (if (eof-object? result) #f result)))))) - (def (shell-quote s) - (string-append "'" (string-replace-all s "'" "'\\''") "'")) - - (def (string-replace-all str old new) - (let ((olen (string-length old)) - (out (open-output-string))) - (let loop ((i 0)) - (cond - ((> (+ i olen) (string-length str)) - (display (substring str i (string-length str)) out) - (get-output-string out)) - ((string=? (substring str i (+ i olen)) old) - (display new out) - (loop (+ i olen))) - (else - (write-char (string-ref str i) out) - (loop (+ i 1))))))) (def (main . args) (parameterize ((program-name "readlink")) --- a/lib/jerboa-coreutils/realpath.sls +++ b/lib/jerboa-coreutils/realpath.sls @@ -30,23 +30,6 @@ (close-port from-stderr) (if (eof-object? result) #f result)))))) - (def (shell-quote s) - (string-append "'" (string-replace-all s "'" "'\\''") "'")) - - (def (string-replace-all str old new) - (let ((olen (string-length old)) - (out (open-output-string))) - (let loop ((i 0)) - (cond - ((> (+ i olen) (string-length str)) - (display (substring str i (string-length str)) out) - (get-output-string out)) - ((string=? (substring str i (+ i olen)) old) - (display new out) - (loop (+ i olen))) - (else - (write-char (string-ref str i) out) - (loop (+ i 1))))))) (def (main . args) (parameterize ((program-name "realpath")) --- a/lib/jerboa-coreutils/rm.sls +++ b/lib/jerboa-coreutils/rm.sls @@ -21,13 +21,14 @@ (define *exit-code* 0) + (define ffi-lstat-type (foreign-procedure "coreutils_lstat_type" (string) int)) + (def (file-type path) ;; -1=not found, 0=file/symlink/other, 1=directory - (with-catch - (lambda (e) -1) - (lambda () - (if (file-directory? path) 1 - (if (file-exists? path) 0 -1))))) + ;; Uses lstat so symlinks are not followed — a symlink to a directory + ;; is reported as 0 (file/other), preventing rm -rf from following + ;; symlinks into other directory trees. + (ffi-lstat-type path)) ;; Confirm removal (def (confirm-remove path type-str) --- a/lib/jerboa-coreutils/shred.sls +++ b/lib/jerboa-coreutils/shred.sls @@ -15,40 +15,16 @@ (jerboa-coreutils common) (jerboa-coreutils common version)) - ;; Get file size via stat command - (def (get-file-size path) - (with-catch - (lambda (e) -1) - (lambda () - (let ((cmd (string-append "stat -c '%s' " (shell-quote path) " 2>/dev/null"))) - (let-values (((to-stdin from-stdout from-stderr pid) - (open-process-ports cmd (buffer-mode block) (native-transcoder)))) - (close-port to-stdin) - (let ((line (get-line from-stdout))) - (close-port from-stdout) - (close-port from-stderr) - (if (or (not line) (eof-object? line)) - -1 - (let ((n (string->number line))) - (if n (inexact->exact n) -1))))))))) + (define _load-ffi (begin (load-shared-object #f) (void))) + (define ffi-file-size (foreign-procedure "coreutils_file_size" (string) long-long)) - (def (shell-quote str) - (string-append "'" (let loop ((i 0) (acc '())) - (if (>= i (string-length str)) - (list->string (reverse acc)) - (let ((c (string-ref str i))) - (if (eqv? c #\') - (loop (+ i 1) (append (reverse (string->list "'\\''")) acc)) - (loop (+ i 1) (cons c acc)))))) "'")) + ;; Get file size via FFI stat + (def (get-file-size path) + (ffi-file-size path)) - ;; Generate a bytevector of random bytes + ;; Generate a bytevector of cryptographically secure random bytes (def (random-bytes n) - (let ((buf (make-bytevector n))) - (let loop ((i 0)) - (when (< i n) - (bytevector-u8-set! buf i (random-integer 256)) - (loop (+ i 1)))) - buf)) + (secure-random-bytes n)) ;; Generate a bytevector of zero bytes (def (zero-bytes n) --- a/lib/jerboa-coreutils/shuf.sls +++ b/lib/jerboa-coreutils/shuf.sls @@ -76,7 +76,7 @@ (result (vector-copy vec))) (let loop ((i (- n 1))) (when (> i 0) - (let ((j (random-integer (+ i 1)))) + (let ((j (secure-random-integer (+ i 1)))) (let ((tmp (vector-ref result i))) (vector-set! result i (vector-ref result j)) (vector-set! result j tmp))) --- a/lib/jerboa-coreutils/stat.sls +++ b/lib/jerboa-coreutils/stat.sls @@ -42,16 +42,6 @@ (if (null? rest) acc (loop (cdr rest) (string-append acc " " (car rest))))))) - ;; Shell-escape a single argument - (def (shell-quote str) - (string-append "'" (let loop ((i 0) (acc '())) - (if (>= i (string-length str)) - (list->string (reverse acc)) - (let ((c (string-ref str i))) - (if (eqv? c #\') - (loop (+ i 1) (append (reverse (string->list "'\\''")) acc)) - (loop (+ i 1) (cons c acc)))))) "'")) - (def (main . args) (parameterize ((program-name "stat")) (call-with-getopt --- a/lib/jerboa-coreutils/stdbuf.sls +++ b/lib/jerboa-coreutils/stdbuf.sls @@ -16,15 +16,6 @@ ;; stdbuf - delegate to /usr/bin/stdbuf ;; Pass all arguments through to the system binary. - (def (shell-quote str) - (string-append "'" (let loop ((i 0) (acc '())) - (if (>= i (string-length str)) - (list->string (reverse acc)) - (let ((c (string-ref str i))) - (if (eqv? c #\') - (loop (+ i 1) (append (reverse (string->list "'\\''")) acc)) - (loop (+ i 1) (cons c acc)))))) "'")) - (def (main . args) (parameterize ((program-name "stdbuf")) (with-catch --- a/lib/jerboa-coreutils/stty.sls +++ b/lib/jerboa-coreutils/stty.sls @@ -16,15 +16,6 @@ ;; stty - delegate to /usr/bin/stty ;; Pass all arguments through to the system binary. - (def (shell-quote str) - (string-append "'" (let loop ((i 0) (acc '())) - (if (>= i (string-length str)) - (list->string (reverse acc)) - (let ((c (string-ref str i))) - (if (eqv? c #\') - (loop (+ i 1) (append (reverse (string->list "'\\''")) acc)) - (loop (+ i 1) (cons c acc)))))) "'")) - (def (main . args) (parameterize ((program-name "stty")) (with-catch