Harden filesystem operations and native loading
ober
81d49507ad81c8a2e0aa44123346b43f9caa34a3
--- a/.build.yml +++ b/.build.yml @@ -5,17 +5,16 @@ packages: - cargo - curl - git + - openssh-client - pkg-config - ripgrep - rustc -environment: - JERBOA_VERSION: v0.2.3 sources: - https://git.sr.ht/~lisp/jerboa-coreutils tasks: - install-jerbuild: | - curl -fsSL "https://github.com/jerboa-lang/jerboa/releases/download/${JERBOA_VERSION}/jerbuild-linux-x86_64" -o "$HOME/jerbuild" - chmod +x "$HOME/jerbuild" + cd jerboa-coreutils + support/install-verified-jerbuild.sh "$HOME/jerbuild" - install-cargo-audit: | cargo install cargo-audit --locked - verify: | --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -13,24 +13,21 @@ jobs: verify: runs-on: ubuntu-latest steps: - - uses: actions/checkout@v4 + - uses: actions/checkout@34e114876b0b11c390a56381ad16ebd13914f8d5 # v4.3.1 - name: Install build tools - run: sudo apt-get update && sudo apt-get install -y build-essential curl ca-certificates git ripgrep pkg-config + run: sudo apt-get update && sudo apt-get install -y build-essential curl ca-certificates git openssh-client ripgrep pkg-config - name: Install Rust - uses: dtolnay/rust-toolchain@stable + uses: dtolnay/rust-toolchain@8fae6aadcd3e1a6f3fcb446ce7f9438c9d1349f1 # 1.94.1 + with: + toolchain: 1.94.1 - name: Install cargo-audit run: cargo install cargo-audit --locked - name: Install jerbuild - run: | - set -eux - curl -fsSL "https://github.com/jerboa-lang/jerboa/releases/download/${JERBOA_VERSION}/jerbuild-linux-x86_64" -o /usr/local/bin/jerbuild - chmod +x /usr/local/bin/jerbuild - env: - JERBOA_VERSION: v0.2.3 + run: support/install-verified-jerbuild.sh /usr/local/bin/jerbuild - name: Verify run: JERBUILD=/usr/local/bin/jerbuild make verify --- a/Makefile +++ b/Makefile @@ -41,6 +41,8 @@ LIBDIRS := lib:$(JH)/lib LOCAL_JERBOA_NATIVE_DIR ?= $(CURDIR)/../jerboa/jerboa-native-rs NATIVE_DIR ?= vendor/jerboa-native-rs JERBOA_REMOTE ?= https://git.sr.ht/~lisp/jerboa +JERBOA_COMMIT ?= 23ad83d28ac65cf6f0d2d702fd32934f207c26bf +JERBOA_NATIVE_TREE ?= 9ddb4914a6e99e1c2966803fab00b9bad5a01335 CARGO_AUDIT ?= cargo audit # Multi-call applet names. The binary dispatches on argv[0]; these are the @@ -129,10 +131,16 @@ vendor-deps: rsync -a --delete --exclude target/ "$(LOCAL_JERBOA_NATIVE_DIR)/" "$(NATIVE_DIR)/"; \ elif [ ! -f "$(NATIVE_DIR)/Cargo.toml" ]; then \ mkdir -p vendor; \ - echo "=== Sparse-cloning jerboa-native-rs from $(JERBOA_REMOTE) ==="; \ + echo "=== Fetching locked jerboa-native-rs $(JERBOA_COMMIT) from $(JERBOA_REMOTE) ==="; \ rm -rf vendor/.jerboa-monorepo; \ - git clone --depth 1 --filter=blob:none --sparse $(JERBOA_REMOTE) vendor/.jerboa-monorepo; \ + git init -q vendor/.jerboa-monorepo; \ + git -C vendor/.jerboa-monorepo remote add origin "$(JERBOA_REMOTE)"; \ + git -C vendor/.jerboa-monorepo sparse-checkout init --cone; \ git -C vendor/.jerboa-monorepo sparse-checkout set jerboa-native-rs; \ + git -C vendor/.jerboa-monorepo fetch -q --depth 1 origin "$(JERBOA_COMMIT)"; \ + test "$$(git -C vendor/.jerboa-monorepo rev-parse FETCH_HEAD)" = "$(JERBOA_COMMIT)"; \ + git -C vendor/.jerboa-monorepo checkout -q --detach "$(JERBOA_COMMIT)"; \ + test "$$(git -C vendor/.jerboa-monorepo rev-parse HEAD:jerboa-native-rs)" = "$(JERBOA_NATIVE_TREE)"; \ mv vendor/.jerboa-monorepo/jerboa-native-rs "$(NATIVE_DIR)"; \ rm -rf vendor/.jerboa-monorepo; \ fi @@ -244,6 +252,7 @@ import-check: gen security: clean-generated scripts/security-check.sh scripts/security-check.sh + JERBUILD="$(JERBUILD)" bash scripts/native-loader-security-test.sh audit: security vendor-deps @echo "==> jerbuild" --- a/SECURITY.md +++ b/SECURITY.md @@ -31,13 +31,20 @@ must be cut from a clean checkout after: - No network capability in project source. - No broad direct `(chezscheme)` imports in runtime, entry, support checks, or tools. -- No Scheme reader evaluation on untrusted inputs. +- Chez rejects `#.` and has no `read-eval` switch. Any caller-selected Scheme + source is instead byte-bounded, parsed with explicit nesting/container/token + limits, and checked against its expected top-level shape. - Native build artifacts must not be committed as source. - PCRE2 is loaded only for `grep`. - Process execution is limited to applets whose purpose requires it. - Production claims must not rely on non-enforcing seccomp/Landlock stubs; use an external sandbox or add verified native enforcement for deployments that require kernel sandboxing. +- `JCOREUTILS_REQUIRE_SECURITY=seccomp`, `landlock`, or `all` fails closed when + that kernel control is unavailable. `JCOREUTILS_SECURITY_STATUS=1` emits the + effective initialization state as a structured association list. +- The compatibility predicate `security-available?` is true only for active + kernel enforcement; audit or taint observability alone never makes it true. - Finding or command output can include file contents, paths, users, process data, and environment values; treat logs and release evidence accordingly. - Target proof files must be marker-only summaries. Do not store raw command --- a/docs/process-and-filesystem-policy.md +++ b/docs/process-and-filesystem-policy.md @@ -32,7 +32,10 @@ Current hardened posture: Kernel sandboxing is not claimed here. The repository no longer calls non-enforcing std seccomp/Landlock stubs as production controls; deployments that require kernel policy must use an external sandbox or a verified native -enforcement layer. +enforcement layer. Set `JCOREUTILS_REQUIRE_SECURITY=seccomp`, `landlock`, or +`all` to make an unavailable required control fatal. Set +`JCOREUTILS_SECURITY_STATUS=1` to emit the effective control/observability state +as a structured association list. Remaining release evidence work: --- a/docs/threat-model.md +++ b/docs/threat-model.md @@ -25,7 +25,9 @@ environment variables. - No network capability in this repository. - No broad direct `(chezscheme)` imports in source or tooling. -- No Scheme reader evaluation on untrusted inputs. +- Chez rejects `#.` and has no `read-eval` switch. Caller-selected Scheme + source must still have byte, nesting, container, token, form-count, and + top-level-shape bounds. - C launcher writes must handle EINTR and short writes. - Native build artifacts must not be committed as source. - File open/write/delete and caller-requested process sinks route through --- a/lib/jerboa-coreutils/common/security.sls +++ b/lib/jerboa-coreutils/common/security.sls @@ -16,7 +16,7 @@ checked-path-value ensure-coreutils-ffi! define-coreutils-foreign sanitize-path safe-path-join/checked with-sensitive-buffer init-security! - security-available?) + security-available? security-state) (import (except (chezscheme) make-hash-table hash-table? iota \x31;+ \x31;- getenv path-extension path-absolute? thread? make-mutex @@ -29,8 +29,13 @@ (prefix (std security secret) secret-) (jerboa core) (jerboa runtime)) (define *audit-logger* #f) + (define *security-state* '()) + (define (security-state) *security-state*) (define (security-available?) - (or *audit-logger* taint-file-proc check-untainted-proc)) + (let ([seccomp (assq 'seccomp *security-state*)] + [landlock (assq 'landlock *security-state*)]) + (or (and seccomp (eq? (cdr seccomp) 'enabled)) + (and landlock (eq? (cdr landlock) 'enabled))))) (define *coreutils-ffi-loaded?* #f) (define (ensure-coreutils-ffi!) (unless *coreutils-ffi-loaded?* @@ -61,15 +66,31 @@ (set! proc (foreign-procedure c-name (arg-type ...) ret-type))) (apply proc args))))])) - (define (load-seccomp!) #f) - (define (install-readonly-seccomp!) #f) - (define (install-io-seccomp!) #f) - (define (install-process-seccomp!) #f) - (define (load-landlock!) #f) - (define (install-proc-only-landlock!) #f) - (define (install-readonly-landlock! . paths) #f) - (define (install-readwrite-landlock! read-paths write-paths) + (define (security-control-required? control) + (let ([required (getenv "JCOREUTILS_REQUIRE_SECURITY")]) + (and required + (or (string-ci=? required "all") + (string-ci=? required (symbol->string control)))))) + (define (unavailable-control! control) + (when (security-control-required? control) + (error 'init-security! + "required kernel security control is unavailable" + control)) #f) + (define (load-seccomp!) (unavailable-control! 'seccomp)) + (define (install-readonly-seccomp!) + (unavailable-control! 'seccomp)) + (define (install-io-seccomp!) + (unavailable-control! 'seccomp)) + (define (install-process-seccomp!) + (unavailable-control! 'seccomp)) + (define (load-landlock!) (unavailable-control! 'landlock)) + (define (install-proc-only-landlock!) + (unavailable-control! 'landlock)) + (define (install-readonly-landlock! . paths) + (unavailable-control! 'landlock)) + (define (install-readwrite-landlock! read-paths write-paths) + (unavailable-control! 'landlock)) (define *current-capabilities* (make-parameter '())) (define-syntax with-fs-read-capability (syntax-rules () @@ -251,9 +272,42 @@ (bytevector-u8-set! name i 0) (loop (+ i 1)))))))])) (define (init-security!) - (load-seccomp!) - (load-landlock!) - (load-audit!) - (load-taint!) - (load-sanitize!) - (load-secret!))) + (let ([required (getenv "JCOREUTILS_REQUIRE_SECURITY")]) + (when (and required + (not (or (string-ci=? required "seccomp") + (string-ci=? required "landlock") + (string-ci=? required "all")))) + (error 'init-security! + "unknown required security control" + required))) + (let ([seccomp-state (if (load-seccomp!) + 'enabled + 'unavailable)] + [landlock-state (if (load-landlock!) + 'enabled + 'unavailable)]) + (load-audit!) + (load-taint!) + (load-sanitize!) + (load-secret!) + (set! *security-state* + (list (cons 'seccomp seccomp-state) + (cons 'landlock landlock-state) + (cons 'audit (if *audit-logger* 'enabled 'disabled)) + (cons + 'taint + (if check-untainted-proc 'enabled 'unavailable)) + (cons + 'sanitize + (if sanitize-path-proc 'enabled 'unavailable)) + (cons + 'secret-wipe + (if wipe-bv-proc 'enabled 'unavailable)))) + (let ([show-status (getenv "JCOREUTILS_SECURITY_STATUS")]) + (when (and show-status + (or (string=? show-status "1") + (string-ci=? show-status "true"))) + (eprintf + "coreutils-security-state: ~s~n" + *security-state*))) + *security-state*))) --- a/lib/jerboa-coreutils/grep/pcre2.sls +++ b/lib/jerboa-coreutils/grep/pcre2.sls @@ -11,30 +11,75 @@ (except (chezscheme) make-hash-table hash-table? iota \x31;+ \x31;- getenv path-extension path-absolute? thread? make-mutex mutex? mutex-name) - (jerboa core) - (jerboa runtime)) + (only (jerboa ffi) load-shared-object*) + (only (std native-loader) native-loader-privileged? + native-loader-development-enabled? + native-loader-validate-library! + native-loader-try-system-symbol!) + (jerboa core) (jerboa runtime)) (define PCRE2_CASELESS 8) (define PCRE2_MULTILINE 1024) (define PCRE2_DOTALL 32) (define PCRE2_UTF 524288) (define PCRE2_ZERO_TERMINATED (- (expt 2 64) 1)) (define pcre2-fns #f) - (define pcre2-lib-names - '("libpcre2-8.so" "libpcre2-8.so.0" "libpcre2-8.dylib" "libpcre2-8.0.dylib" - "/opt/homebrew/lib/libpcre2-8.dylib" - "/usr/local/lib/libpcre2-8.dylib")) + (define (ensure-native-loader-environment-clean!) + (for-each + (lambda (name) + (let ([value (getenv name)]) + (when (and value (> (string-length value) 0)) + (error 'pcre2 + "dynamic-loader override variables are not accepted" + name)))) + '("DYLD_LIBRARY_PATH" + "DYLD_FALLBACK_LIBRARY_PATH" + "DYLD_INSERT_LIBRARIES" + "LD_LIBRARY_PATH" + "LD_PRELOAD"))) + (define (pcre2-abi-canary?) + (guard (e [(condition? e) #f]) + (let* ([probe (foreign-procedure "pcre2_config_8" + (unsigned-32 u8*) + int)] + [version (make-bytevector 64 0)] + [rc (probe 11 version)]) + (and (>= rc 0) (not (= (bytevector-u8-ref version 0) 0)))))) + (define (load-fixed-system-pcre2!) + (native-loader-try-system-symbol! 'pcre2 "pcre2_config_8" + "/opt/homebrew/lib/libpcre2-8.dylib" + "/usr/local/lib/libpcre2-8.dylib" + "/usr/local/lib/libpcre2-8.so.0" + "/usr/local/lib/libpcre2-8.so" "/usr/lib/libpcre2-8.so.0" + "/usr/lib/x86_64-linux-gnu/libpcre2-8.so.0" + "/lib/x86_64-linux-gnu/libpcre2-8.so.0" + "/usr/lib/aarch64-linux-gnu/libpcre2-8.so.0" + "/lib/aarch64-linux-gnu/libpcre2-8.so.0" + "/usr/lib64/libpcre2-8.so.0" "/lib64/libpcre2-8.so.0")) + (define (configured-development-pcre2) + (and (not (native-loader-privileged?)) + (let ([path (getenv "JCOREUTILS_PCRE2_LIB")]) + (and path + (begin + (unless (native-loader-development-enabled? + "JCOREUTILS_DEV_NATIVE") + (error 'pcre2 + "JCOREUTILS_PCRE2_LIB requires JCOREUTILS_DEV_NATIVE=1")) + (native-loader-validate-library! 'pcre2 path #t)))))) (define (load-pcre2-lib!) - (let loop ([names pcre2-lib-names]) - (cond - [(null? names) - (error 'pcre2 - "could not load libpcre2-8 (tried: ~a)" - pcre2-lib-names)] - [(guard (e [(condition? e) #f]) - (load-shared-object (car names)) - #t) - #t] - [else (loop (cdr names))]))) + (or (pcre2-abi-canary?) + (let ([configured (getenv "JCOREUTILS_PCRE2_LIB")]) + (if configured + (let ([path (configured-development-pcre2)]) + (load-shared-object* path) + (or (pcre2-abi-canary?) + (error 'pcre2 + "configured PCRE2 library failed ABI canary" + path))) + (begin + (ensure-native-loader-environment-clean!) + (or (and (load-fixed-system-pcre2!) (pcre2-abi-canary?)) + (error 'pcre2 + "PCRE2 unavailable at fixed system paths; use JCOREUTILS_DEV_NATIVE=1 with a canonical JCOREUTILS_PCRE2_LIB"))))))) (define (ensure-pcre2!) (unless pcre2-fns (load-pcre2-lib!) --- a/lib/jerboa-coreutils/install.sls +++ b/lib/jerboa-coreutils/install.sls @@ -14,31 +14,23 @@ (jerboa-coreutils common security) (jerboa core) (jerboa runtime)) (def (parse-octal-mode str) (string->number str 8)) - (def (copy-file-contents src dst) - (let* ([in (with-catch - (lambda (e) - (die "cannot open '~a' for reading: ~a" - src - (error-message e))) - (lambda () (open-file-input-port src)))] - [out (with-catch - (lambda (e) - (close-port in) - (die "cannot open '~a' for writing: ~a" - dst - (error-message e))) - (lambda () - (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))) + (def (copy-file-to-port src out) + (let ([in (with-catch + (lambda (e) + (die "cannot open '~a' for reading: ~a" + src + (error-message e))) + (lambda () (open-file-input-port src)))]) + (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))))) (def (resolve-uid-install spec) (if (not spec) -1 @@ -80,15 +72,28 @@ (when verbose (eprintf "install: creating directory '~a'\n" dir))) (def (install-file src dst mode-val uid gid verbose strip) - (copy-file-contents src dst) - (when mode-val - (let ([rc (ffi-chmod dst mode-val)]) - (when (< rc 0) - (warn "cannot change permissions of '~a'" dst)))) - (when (or (>= uid 0) (>= gid 0)) - (let ([rc (ffi-chown dst uid gid)]) - (when (< rc 0) - (warn "cannot change ownership of '~a'" dst)))) + (let ([fd (ffi-install-begin dst)]) + (when (< fd 0) + (die "cannot create a secure temporary file for '~a'" dst)) + (let ([out (open-fd-output-port fd (buffer-mode block) #f)] + [committed? #f]) + (dynamic-wind + (lambda () (void)) + (lambda () + (copy-file-to-port src out) + (flush-output-port out) + (when (< (ffi-install-metadata fd mode-val uid gid) 0) + (error 'install-file + "cannot apply destination metadata" + dst)) + (when (< (ffi-install-commit) 0) + (error 'install-file + "cannot publish destination atomically" + dst)) + (set! committed? #t)) + (lambda () + (close-port out) + (unless committed? (ffi-install-abort)))))) (when verbose (eprintf "install: '~a' -> '~a'\n" src dst))) (def (path-basename path) (let loop ([i (- (string-length path) 1)]) @@ -183,4 +188,24 @@ ffi-getgrnam-gid-c "coreutils_getgrnam_gid" (string) - int)) + int) + (define-coreutils-foreign + ffi-install-begin + "coreutils_install_begin" + (string) + int) + (define-coreutils-foreign + ffi-install-metadata + "coreutils_install_metadata" + (int int int int) + int) + (define-coreutils-foreign + ffi-install-commit + "coreutils_install_commit" + () + int) + (define-coreutils-foreign + ffi-install-abort + "coreutils_install_abort" + () + void)) --- a/lib/jerboa-coreutils/mv.sls +++ b/lib/jerboa-coreutils/mv.sls @@ -21,74 +21,84 @@ [(eqv? (string-ref path i) #\/) (substring path (+ i 1) (string-length path))] [else (loop (- i 1))]))) - (def (file-type path) - (with-catch - (lambda (e) -1) - (lambda () - (if (file-directory? path) - 1 - (if (file-exists? path) 0 -1))))) + (def (file-type path) (ffi-lstat-type path)) (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))) + (let ([in (open-file-input-port src)]) + (dynamic-wind + (lambda () (void)) + (lambda () + (let ([out (open-file-output-port + dst + (file-options no-fail))]) + (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))))) + (flush-output-port out)) + (lambda () (close-port out))))) + (lambda () (close-port in))) + #t)) + (def (copy-symlink src dst) + (let ([target (ffi-readlink src)]) + (and target + (begin + (when (>= (file-type dst) 0) (ffi-unlink dst)) + (zero? (ffi-symlink target dst)))))) (def (copy-dir-recursive src dst) - (with-catch - (lambda (e) - (warn - "cannot create directory '~a': ~a" - dst - (error-message e)) - (set! *exit-code* 1)) - (lambda () (mkdir dst))) - (with-catch - (lambda (e) - (warn - "cannot open directory '~a': ~a" - src - (error-message e)) - (set! *exit-code* 1)) - (lambda () - (let ([entries (directory-list src)]) - (for-each - (lambda (name) - (let ([s (string-append src "/" name)] - [d (string-append dst "/" name)]) - (let ([ftype (file-type s)]) - (cond - [(= ftype 1) (copy-dir-recursive s d)] - [(>= ftype 0) - (with-catch - (lambda (e) - (warn - "cannot copy '~a' to '~a': ~a" - s - d - (error-message e)) - (set! *exit-code* 1)) - (lambda () (copy-file-data s d)))])))) - entries))))) - (def (remove-recursive path) - (let ([ftype (file-type path)]) - (cond - [(= ftype 1) - (with-catch - (lambda (e) #f) - (lambda () - (let ([entries (directory-list path)]) - (for-each - (lambda (name) - (remove-recursive (string-append path "/" name))) - entries)))) - (ffi-rmdir path)] - [(>= ftype 0) (ffi-unlink path)]))) + (let ([success? #t]) + (with-catch + (lambda (e) + (warn + "cannot create directory '~a': ~a" + dst + (error-message e)) + (set! *exit-code* 1) + (set! success? #f)) + (lambda () (mkdir dst))) + (when success? + (with-catch + (lambda (e) + (warn + "cannot open directory '~a': ~a" + src + (error-message e)) + (set! *exit-code* 1) + (set! success? #f)) + (lambda () + (let ([entries (directory-list src)]) + (for-each + (lambda (name) + (let ([s (string-append src "/" name)] + [d (string-append dst "/" name)]) + (let ([ftype (file-type s)]) + (cond + [(= ftype 1) + (unless (copy-dir-recursive s d) + (set! success? #f))] + [(= ftype 2) + (unless (copy-symlink s d) + (warn "cannot copy symbolic link '~a'" s) + (set! *exit-code* 1) + (set! success? #f))] + [(= ftype 0) + (with-catch + (lambda (e) + (warn + "cannot copy '~a' to '~a': ~a" + s + d + (error-message e)) + (set! *exit-code* 1) + (set! success? #f)) + (lambda () (copy-file-data s d)))])))) + entries))))) + success?)) + (def (remove-recursive path) (ffi-remove-tree path 0)) (def (confirm-overwrite dst) (eprintf "mv: overwrite '~a'? " dst) (let ([resp (get-line (current-input-port))]) @@ -110,28 +120,60 @@ (when (>= src-type 0) (audit-file-modify! src) (audit-file-modify! dst) - (let ([rc (ffi-rename src dst)]) - (if (zero? rc) - (when verbose - (eprintf "renamed '~a' -> '~a'\n" src dst)) - (begin - (if (= src-type 1) - (begin - (copy-dir-recursive src dst) - (remove-recursive src)) - (with-catch - (lambda (e) + (let ([rc (ffi-rename-for-move src dst)]) + (cond + [(zero? rc) + (when verbose + (eprintf "renamed '~a' -> '~a'\n" src dst))] + [(= rc 1) + (let ([fallback-type (file-type src)]) + (cond + [(= fallback-type 1) + (when (copy-dir-recursive src dst) + (when (< (remove-recursive src) 0) + (warn + "cannot remove source directory '~a'" + src) + (set! *exit-code* 1)))] + [(= fallback-type 2) + (if (copy-symlink src dst) + (when (< (ffi-unlink src) 0) (warn - "cannot move '~a' to '~a': ~a" - src - dst - (error-message e)) + "cannot remove source symbolic link '~a'" + src) (set! *exit-code* 1)) - (lambda () - (copy-file-data src dst) - (ffi-unlink src)))) - (when verbose - (eprintf "'~a' -> '~a'\n" src dst))))))))))) + (begin + (warn + "cannot move symbolic link '~a' to '~a'" + src + dst) + (set! *exit-code* 1)))] + [(= fallback-type 0) + (with-catch + (lambda (e) + (warn + "cannot move '~a' to '~a': ~a" + src + dst + (error-message e)) + (set! *exit-code* 1)) + (lambda () + (when (copy-file-data src dst) + (when (< (ffi-unlink src) 0) + (warn "cannot remove source '~a'" src) + (set! *exit-code* 1)))))] + [else + (warn + "source '~a' changed during cross-device move" + src) + (set! *exit-code* 1)])) + (when verbose (eprintf "'~a' -> '~a'\n" src dst))] + [else + (warn + "cannot move '~a' to '~a': rename failed" + src + dst) + (set! *exit-code* 1)])))))))) (def (main . args) (parameterize ([program-name "mv"]) (init-security!) @@ -180,8 +222,8 @@ "explain what is being done") (rest-arguments 'rest)))) (define-coreutils-foreign - ffi-rename - "rename" + ffi-rename-for-move + "coreutils_rename_for_move" (string string) int) (define-coreutils-foreign ffi-unlink "unlink" (string) int) @@ -190,4 +232,24 @@ ffi-chmod "chmod" (string int) + int) + (define-coreutils-foreign + ffi-lstat-type + "coreutils_lstat_type" + (string) + int) + (define-coreutils-foreign + ffi-readlink + "coreutils_cp_readlink" + (string) + string) + (define-coreutils-foreign + ffi-symlink + "coreutils_symlink" + (string string) + int) + (define-coreutils-foreign + ffi-remove-tree + "coreutils_remove_tree" + (string int) int)) --- a/lib/jerboa-coreutils/rm.sls +++ b/lib/jerboa-coreutils/rm.sls @@ -59,7 +59,8 @@ (set! *exit-code* 1)] [else (when verbose (eprintf "removed '~a'\n" path))])))]))) - (def (remove-recursive path force interactive verbose) + (def (remove-recursive path force interactive verbose + allow-root) (let ([ftype (file-type path)]) (cond [(< ftype 0) @@ -69,25 +70,14 @@ [(= ftype 1) (when (or (not interactive) (confirm-remove path "directory")) - (with-catch - (lambda (e) - (warn - "cannot open directory '~a': ~a" - path - (error-message e)) - (set! *exit-code* 1)) - (lambda () - (let ([entries (directory-list path)]) - (for-each - (lambda (name) - (remove-recursive - (string-append path "/" name) - force - interactive - verbose)) - entries)))) - (let ([rc (ffi-rmdir path)]) + (audit-file-delete! path) + (let ([rc (ffi-remove-tree path (if allow-root 1 0))]) (cond + [(= rc -2) + (warn + "it is dangerous to operate recursively on '~a'" + path) + (set! *exit-code* 1)] [(< rc 0) (warn "cannot remove '~a'" path) (set! *exit-code* 1)] @@ -112,18 +102,21 @@ (lambda (_ opt) (when (null? (hash-ref opt 'rest)) (unless (hash-get opt 'force) (die "missing operand"))) - (when (and (not (hash-get opt 'no-preserve-root)) - (member "/" (hash-ref opt 'rest))) + (when (and (hash-get opt 'recursive) + (not (hash-get opt 'no-preserve-root)) + (let loop ([paths (hash-ref opt 'rest)]) + (and (pair? paths) + (or (= (ffi-path-is-root (car paths)) 1) + (loop (cdr paths)))))) (die "it is dangerous to operate recursively on '/'\nUse --no-preserve-root to override this failsafe.")) (set! *exit-code* 0) (for-each (lambda (path) (if (hash-get opt 'recursive) - (remove-recursive - path - (hash-get opt 'force) + (remove-recursive path (hash-get opt 'force) (hash-get opt 'interactive) - (hash-get opt 'verbose)) + (hash-get opt 'verbose) + (hash-get opt 'no-preserve-root)) (remove-one path (hash-get opt 'force) (hash-get opt 'interactive) (hash-get opt 'verbose) (hash-get opt 'dir)))) @@ -154,4 +147,14 @@ ffi-lstat-type "coreutils_lstat_type" (string) + int) + (define-coreutils-foreign + ffi-path-is-root + "coreutils_path_is_root" + (string) + int) + (define-coreutils-foreign + ffi-remove-tree + "coreutils_remove_tree" + (string int) int)) --- a/lib/jerboa-coreutils/shred.sls +++ b/lib/jerboa-coreutils/shred.sls @@ -13,10 +13,9 @@ (only (std format) eprintf format) (std cli getopt) (jerboa-coreutils common) (jerboa-coreutils common version) (jerboa-coreutils common security) (jerboa runtime)) - (def (get-file-size path) (ffi-file-size path)) (def (random-bytes n) (secure-random-bytes n)) (def (zero-bytes n) (make-bytevector n 0)) - (def (overwrite-pass path file-size generator verbose + (def (overwrite-pass port path file-size generator verbose pass-label) (when verbose (eprintf "shred: ~a: pass ~a\n" path pass-label)) @@ -24,51 +23,59 @@ (lambda (e) (warn "~a: cannot overwrite: ~a" path (error-message e))) (lambda () - (let ([port (open-file-output-port - path - (file-options no-create no-truncate))]) - (let* ([buf-size 65536] [remaining file-size]) - (let loop ([left remaining]) - (when (> left 0) - (let* ([chunk-size (min buf-size left)] - [buf (generator chunk-size)]) - (put-bytevector port buf 0 chunk-size) - (let wipe ([i 0]) - (when (< i (bytevector-length buf)) - (bytevector-u8-set! buf i 0) - (wipe (+ i 1)))) - (loop (- left chunk-size)))))) - (flush-output-port port) - (close-port port))))) + (set-port-position! port 0) + (let* ([buf-size 65536] [remaining file-size]) + (let loop ([left remaining]) + (when (> left 0) + (let* ([chunk-size (min buf-size left)] + [buf (generator chunk-size)]) + (put-bytevector port buf 0 chunk-size) + (let wipe ([i 0]) + (when (< i (bytevector-length buf)) + (bytevector-u8-set! buf i 0) + (wipe (+ i 1)))) + (loop (- left chunk-size)))))) + (flush-output-port port)))) (def (shred-file path passes zero-pass remove verbose exact) (audit-file-modify! path) - (let ([file-size (get-file-size path)]) - (when (< file-size 0) - (warn "~a: No such file or directory" path)) - (when (>= file-size 0) - (let loop ([i 1]) - (when (<= i passes) - (overwrite-pass path file-size random-bytes verbose - (string-append - (number->string i) - "/" - (number->string passes) - " (random)")) - (loop (+ i 1)))) - (when zero-pass - (overwrite-pass path file-size zero-bytes verbose - (string-append - (number->string (+ passes 1)) - "/" - (number->string (+ passes 1)) - " (000000)"))) - (when remove - (with-catch - (lambda (e) - (warn "~a: cannot remove: ~a" path (error-message e))) - (lambda () - (checked-delete-file path) - (when verbose (eprintf "shred: ~a: removed\n" path)))))))) + (let ([fd (ffi-open-regular-nofollow path)]) + (if (< fd 0) + (warn + "~a: refusing symbolic link, non-regular file, or unsafe path" + path) + (let ([file-size (ffi-fd-size fd)] + [port (open-fd-output-port fd (buffer-mode block) #f)]) + (dynamic-wind + (lambda () (void)) + (lambda () + (let loop ([i 1]) + (when (<= i passes) + (overwrite-pass port path file-size random-bytes verbose + (string-append + (number->string i) + "/" + (number->string passes) + " (random)")) + (loop (+ i 1)))) + (when zero-pass + (overwrite-pass port path file-size zero-bytes verbose + (string-append + (number->string (+ passes 1)) + "/" + (number->string (+ passes 1)) + " (000000)"))) + (flush-output-port port) + (when (< (ffi-fsync fd) 0) + (warn "~a: cannot synchronize overwritten data" path)) + (when remove + (audit-file-delete! path) + (if (zero? (ffi-unlink-if-same fd path)) + (when verbose + (eprintf "shred: ~a: removed\n" path)) + (warn + "~a: pathname changed during shredding; refusing removal" + path)))) + (lambda () (close-port port))))))) (def (main . args) (parameterize ([program-name "shred"]) (init-security!) @@ -100,7 +107,22 @@ "do not round file sizes up to the next full block") (rest-arguments 'rest)))) (define-coreutils-foreign - ffi-file-size - "coreutils_file_size" + ffi-open-regular-nofollow + "coreutils_open_regular_nofollow" (string) - long-long)) + int) + (define-coreutils-foreign + ffi-fd-size + "coreutils_fd_size" + (int) + long-long) + (define-coreutils-foreign + ffi-fsync + "coreutils_fsync" + (int) + int) + (define-coreutils-foreign + ffi-unlink-if-same + "coreutils_unlink_if_same" + (int string) + int)) --- a/lib/jerboa-coreutils/timeout.sls +++ b/lib/jerboa-coreutils/timeout.sls @@ -9,16 +9,29 @@ getenv path-extension path-absolute? thread? make-mutex mutex? mutex-name string-upcase) (only (std sugar) with-catch) (only (std format) eprintf) + (only (std os fd) spawn-process process-pid process-wait + process-exited? process-exit-code process-signaled? + process-signal) (jerboa-coreutils common) (jerboa-coreutils common version) (jerboa-coreutils common security) (jerboa core) (jerboa runtime)) - (def (string-join strs sep) - (if (null? strs) - "" - (let loop ([rest (cdr strs)] [acc (car strs)]) - (if (null? rest) - acc - (loop (cdr rest) (string-append acc sep (car rest))))))) + (def (monotonic-seconds) + (let ([now (current-time 'time-monotonic)]) + (+ (time-second now) + (/ (time-nanosecond now) 1000000000.0)))) + (def (wait-until proc deadline) + (let loop () + (let ([status (process-wait proc #t)]) + (cond + [status status] + [(>= (monotonic-seconds) deadline) #f] + [else (thread-sleep! 0.01) (loop)])))) + (def (decoded-process-status proc) + (cond + [(process-exited? proc) (or (process-exit-code proc) 1)] + [(process-signaled? proc) + (+ 128 (or (process-signal proc) 0))] + [else 1])) (def (parse-duration str) (let* ([len (string-length str)] [suffix (if (> len 0) (string-ref str (- len 1)) #\s)] @@ -110,35 +123,27 @@ (let* ([duration (parse-duration (car args))]