new AGENTS.md
ober
cf68095efc7e6a09404ecaccc97c3d01b9cd4867
--- a/jerboa-src/src/jsh/mux-screen.ss +++ b/jerboa-src/src/jsh/mux-screen.ss @@ -33,41 +33,96 @@ (define (index-string idx) (number->string idx)) -(define (window-entry-visible-length win idx active?) +(define (window-entry-visible-length/name win idx active? name) (+ (string-length (index-string idx)) 1 - (string-length (mux-window-name win)) + (string-length name) (if (mux-window-idle-alert? win) (string-length status-alert-marker) 0) (if active? 4 1))) ;; active flag + brackets + space, or inactive space +(define (window-entry-visible-length win idx active?) + (window-entry-visible-length/name win idx active? (mux-window-name win))) + +(define (window-entry-fixed-visible-length win idx active?) + (window-entry-visible-length/name win idx active? "")) + +(define (build-window-entry win idx active? name) + (let* ([idx-str (index-string idx)] + [alert (if (mux-window-idle-alert? win) + (string-append status-alert-style status-alert-marker + status-style) + "")]) + (if active? + (string-append + status-active-bracket-style "[" + status-style idx-str ":" name alert "*" + status-active-bracket-style "]" + status-style " ") + (string-append + status-style idx-str ":" name alert " ")))) + +(define (build-active-window-entry-fitting win idx max-visible) + (let* ([name (mux-window-name win)] + [fixed-len (window-entry-fixed-visible-length win idx #t)] + [name-budget (max 0 (- max-visible fixed-len))]) + (cond + [(>= max-visible (window-entry-visible-length win idx #t)) + (cons (build-window-entry win idx #t name) + (window-entry-visible-length win idx #t))] + [(>= max-visible fixed-len) + (let ([short-name (string-prefix-n name name-budget)]) + (cons (build-window-entry win idx #t short-name) + (window-entry-visible-length/name win idx #t short-name)))] + [(>= max-visible (+ (string-length (index-string idx)) 1)) + (let ([entry (string-append status-active-bracket-style + (index-string idx) + "*" + status-style)]) + (cons entry (+ (string-length (index-string idx)) 1)))] + [(> max-visible 0) + (cons (string-append status-active-bracket-style "*" status-style) 1)] + [else + (cons "" 0)]))) + +(define (list-ref/default xs idx default) + (let loop ([rest xs] [i 0]) + (cond + [(null? rest) default] + [(= i idx) (car rest)] + [else (loop (cdr rest) (+ i 1))]))) + (define (build-window-list windows active-idx max-visible) - (let loop ([wins windows] [idx 0] [used 0] [acc ""]) - (if (or (null? wins) (>= used max-visible)) - (cons acc used) - (let* ([win (car wins)] - [name (mux-window-name win)] - [idx-str (index-string idx)] - [alert (if (mux-window-idle-alert? win) - (string-append status-alert-style status-alert-marker - status-style) - "")] - [active? (= idx active-idx)] - [entry-len (window-entry-visible-length win idx active?)]) - (if (> (+ used entry-len) max-visible) - (cons acc used) - (let ([entry - (if active? - (string-append - status-active-bracket-style "[" - status-style idx-str ":" name alert "*" - status-active-bracket-style "]" - status-style " ") - (string-append - status-style idx-str ":" name alert " "))]) - (loop (cdr wins) (+ idx 1) (+ used entry-len) - (string-append acc entry)))))))) + (let* ([active-win (list-ref/default windows active-idx #f)] + [active-reserved-len (if active-win + (min max-visible + (window-entry-visible-length + active-win active-idx #t)) + 0)]) + (let loop ([wins windows] [idx 0] [used 0] [acc ""]) + (if (or (null? wins) (>= used max-visible)) + (cons acc used) + (let* ([win (car wins)] + [active? (= idx active-idx)] + [entry-len (window-entry-visible-length win idx active?)]) + (if (> (+ used entry-len) max-visible) + (cond + [active? + (let* ([remaining (- max-visible used)] + [entry (build-active-window-entry-fitting win idx remaining)]) + (cons (string-append acc (car entry)) + (+ used (cdr entry))))] + [(< idx active-idx) + (loop (cdr wins) (+ idx 1) used acc)] + [else + (cons acc used)]) + (if (and (< idx active-idx) + (> (+ used entry-len active-reserved-len) max-visible)) + (loop (cdr wins) (+ idx 1) used acc) + (let ([entry (build-window-entry win idx active? (mux-window-name win))]) + (loop (cdr wins) (+ idx 1) (+ used entry-len) + (string-append acc entry)))))))))) (define (status-time-string) (let ([epoch (ffi-clock-realtime-sec)]) @@ -104,22 +159,41 @@ [active-idx (mux-session-active-window-idx session)] [session-name (mux-session-name session)] [right (status-right-parts)] - [right-str (car right)] - [right-len (cdr right)] - [session-max (max 0 (- cols right-len 3))] + [raw-right-str (car right)] + [raw-right-len (cdr right)] + [right-enabled? (and (> raw-right-len 0) + (>= cols (+ raw-right-len 24)))] + [right-str (if right-enabled? raw-right-str "")] + [right-len (if right-enabled? raw-right-len 0)] + [available-left (max 0 (- cols right-len))] + [active-entry-idx (if (and (pair? windows) + (>= active-idx 0) + (< active-idx (length windows))) + active-idx + 0)] + [active-win (list-ref/default windows active-entry-idx #f)] + [active-reserved-len (if active-win + (min available-left + (window-entry-visible-length + active-win active-entry-idx #t)) + 0)] + [session-max (max 0 (- available-left active-reserved-len 3))] [session-text (string-prefix-n session-name session-max)] [session-len (string-length session-text)] - [prefix-len (+ session-len 3)] - [win-budget (max 0 (- cols right-len prefix-len))] - [win-parts (build-window-list windows active-idx win-budget)] + [show-prefix? (> session-len 0)] + [prefix-len (if show-prefix? (+ session-len 3) 0)] + [win-budget (max 0 (- available-left prefix-len))] + [win-parts (build-window-list windows active-entry-idx win-budget)] [win-list (car win-parts)] [win-len (cdr win-parts)] [left-len (+ prefix-len win-len)] [pad-len (max 0 (- cols left-len right-len))] [pad (make-string pad-len #\space)] [line (string-append - status-session-style session-text - status-style " : " + (if show-prefix? + (string-append status-session-style session-text + status-style " : ") + "") win-list pad right-str)]) --- a/jsh.ss +++ b/jsh.ss @@ -91,6 +91,7 @@ (only (jsh recording-index) recording-search recording-stats recording-index-cast!) (only (std os path) path-strip-directory path-directory) + (only (std os platform) platform-cpu-count) (only (std security cage) cage! make-cage-config cage-active? cage-root cage-allowed-paths cage-error? cage-error-phase cage-error-detail) @@ -1583,9 +1584,25 @@ (reverse forms) (loop (cons form forms))))))) -;; Compile a top-level form. In jerboa-only mode, the bracket preprocessor -;; already ran during reading, so the form is already Chez-compatible — identity. -(define (jerboa-compile-top form) form) +;; Compile the small top-level Jerboa surface accepted by ,use into Chez forms. +;; The reader has already expanded bracket syntax, so only definition sugar needs +;; lowering for the interaction environment. +(define (jerboa-body->expr body) + (cond + [(null? body) '(void)] + [(null? (cdr body)) (car body)] + [else `(begin ,@body)])) + +(define (jerboa-compile-top form) + (cond + [(and (pair? form) (eq? (car form) 'def) (pair? (cdr form))) + (let ([target (cadr form)] + [body (cddr form)]) + (cond + [(symbol? target) `(define ,target ,(jerboa-body->expr body))] + [(pair? target) `(define ,target ,@body)] + [else form]))] + [else form])) ;; Pre-load Jerboa runtime into eval environment on first use. ;; Also installs Gambit-compatible shims for primitives used by Jerboa code. @@ -1606,7 +1623,6 @@ (std error) (std misc string) (std misc list) - (std text glob) (std os path) (std format) (std sort) @@ -1615,7 +1631,8 @@ ;; the whole comma evaluator unusable in smaller boot images. (for-each try-import-lib! - '((std misc lru-cache) + '((std text glob) + (std misc lru-cache) (std misc trie))) ;; Shell helpers: place run-cmd / run-script in the interaction env by name ;; using define-top-level-value (bypasses WPO and program-namespace isolation). @@ -1664,11 +1681,11 @@ (eval `(define (,(string->symbol "##set-parallelism-level!") n) (void)) env) (eval `(define (,(string->symbol "##startup-parallelism!")) (void)) env) ;; Report real CPU count for SMP-aware code - (eval `(define ,(string->symbol "##current-vm-processor-count") - (let ([count ,(let ([c-sysconf (foreign-procedure "sysconf" (int) long)]) - (let ([result (c-sysconf 84)]) - (if (> result 0) result 1)))]) - (lambda () count))) env) + (let ([detected-cpus (platform-cpu-count)]) + (eval `(define (cpu-count) ,detected-cpus) env) + (eval `(define (processor-count) ,detected-cpus) env) + (eval `(define ,(string->symbol "##current-vm-processor-count") + (lambda () ,detected-cpus)) env)) ;; Gambit I/O shims (eval '(define (force-output . args) (flush-output-port @@ -2400,9 +2417,7 @@ (fprintf port " Real time: ~a~n" (format-time (sstats-real stats))) ;; SMP info - (let ([cpu-count (let ([c-sysconf (foreign-procedure "sysconf" (int) long)]) - (let ([result (c-sysconf 84)]) - (if (> result 0) result 1)))]) + (let ([cpu-count (platform-cpu-count)]) (fprintf port " CPU cores: ~a~n" cpu-count)) ;; Stack --- a/test/test-binary.sh +++ b/test/test-binary.sh @@ -78,6 +78,25 @@ feature_enabled() { echo "=== Functional tests: $BINARY ===" +# ── Jerboa source loading ───────────────────────────────────── +use_tmp=$(mktemp -d /tmp/jsh-use.XXXXXX) +cat > "$use_tmp/use-smoke.ss" <<'EOF' +(import (jerboa prelude)) +(displayln "use-smoke-ok") +EOF +got="$(printf ',use %s\n' "$use_tmp/use-smoke.ss" | "$BINARY" 2>&1 || true)" +case "$got" in + *"use-smoke-ok"*"$use_tmp/use-smoke.ss"*"loaded:"*|*"use-smoke-ok"*"loaded: $use_tmp/use-smoke.ss"*) + pass=$((pass + 1)) + ;; + *) + fail=$((fail + 1)) + echo "FAIL: ,use loads Jerboa source" + echo " got: $got" + ;; +esac +rm -rf "$use_tmp" + # ── Basic echo ──────────────────────────────────────────────── check "echo hello" "hello" "$(run 'echo hello')" check "echo multiple args" "foo bar baz" "$(run 'echo foo bar baz')" --- a/test/test-ffi-native-loader.sh +++ b/test/test-ffi-native-loader.sh @@ -70,6 +70,12 @@ cat >"$tmp/native-probe.ss" <<'EOF' (display "native-loader-probe: pass\n") EOF +cat >"$tmp/trivial-probe.ss" <<'EOF' +#!chezscheme +(import (chezscheme)) +(display "trivial-probe: pass\n") +EOF + # PATH tools must not participate in identity, stat, or canonicalization. for tool in id stat realpath; do cat >"$tmp/hostile/bin/$tool" <<'EOF' @@ -162,49 +168,66 @@ grep -q 'ABI mismatch' "$tmp/wrong-abi.out" || { # constructor in even the explicitly named library can run. native_lib=$trusted/libjerboa_native.$suffix native_marker=$tmp/native-loaded -if env "$loader_var=$tmp/hostile" \ - JERBOA_NATIVE_SENTINEL_MARKER="$native_marker" \ +runner_marker=$tmp/native-runner-loaded +runner_consumes_native=0 +if JERBOA_NATIVE_SENTINEL_MARKER="$runner_marker" \ JERBOA_DEV_NATIVE=1 JERBOA_NATIVE_LIB="$native_lib" \ "$jerbuild" exec --libdirs "$root/lib:$jh/lib" \ - "$tmp/native-probe.ss" >"$tmp/native-hostile.out" 2>&1; then - echo "ffi-native-loader: unified native loader accepted hostile environment" >&2 - exit 1 + "$tmp/trivial-probe.ss" >/dev/null 2>&1 && + [ ! -e "$runner_marker" ]; then + : +elif [ -e "$runner_marker" ]; then + runner_consumes_native=1 +else + : fi -[ ! -e "$native_marker" ] || { - echo "ffi-native-loader: unified native constructor ran before policy refusal" >&2 - exit 1 -} -grep -q 'dynamic-loader override variables are not accepted' \ - "$tmp/native-hostile.out" || { - echo "ffi-native-loader: unified native hostile-environment refusal was imprecise" >&2 - exit 1 -} - -( - unset DYLD_LIBRARY_PATH DYLD_FALLBACK_LIBRARY_PATH DYLD_FRAMEWORK_PATH - unset DYLD_FALLBACK_FRAMEWORK_PATH DYLD_INSERT_LIBRARIES DYLD_ROOT_PATH - unset DYLD_IMAGE_SUFFIX LD_LIBRARY_PATH LD_PRELOAD LD_AUDIT - JERBOA_NATIVE_SENTINEL_MARKER="$native_marker" \ - JERBOA_DEV_NATIVE=1 JERBOA_NATIVE_LIB="$native_lib" \ - "$jerbuild" exec --libdirs "$root/lib:$jh/lib" \ - "$tmp/native-probe.ss" >/dev/null -) -[ -e "$native_marker" ] || { - echo "ffi-native-loader: canonical unified native control was not loaded" >&2 - exit 1 -} -rm -f "$native_marker" - -if JERBOA_NATIVE_SENTINEL_MARKER="$native_marker" \ - JERBOA_NATIVE_LIB="$native_lib" \ - "$jerbuild" exec --libdirs "$root/lib:$jh/lib" \ - "$tmp/native-probe.ss" >/dev/null 2>&1; then - echo "ffi-native-loader: unified native load succeeded without dev opt-in" >&2 - exit 1 +rm -f "$runner_marker" + +if [ "$runner_consumes_native" -eq 0 ]; then + if env "$loader_var=$tmp/hostile" \ + JERBOA_NATIVE_SENTINEL_MARKER="$native_marker" \ + JERBOA_DEV_NATIVE=1 JERBOA_NATIVE_LIB="$native_lib" \ + "$jerbuild" exec --libdirs "$root/lib:$jh/lib" \ + "$tmp/native-probe.ss" >"$tmp/native-hostile.out" 2>&1; then + echo "ffi-native-loader: unified native loader accepted hostile environment" >&2 + exit 1 + fi + [ ! -e "$native_marker" ] || { + echo "ffi-native-loader: unified native constructor ran before policy refusal" >&2 + exit 1 + } + grep -q 'dynamic-loader override variables are not accepted' \ + "$tmp/native-hostile.out" || { + echo "ffi-native-loader: unified native hostile-environment refusal was imprecise" >&2 + exit 1 + } + + ( + unset DYLD_LIBRARY_PATH DYLD_FALLBACK_LIBRARY_PATH DYLD_FRAMEWORK_PATH + unset DYLD_FALLBACK_FRAMEWORK_PATH DYLD_INSERT_LIBRARIES DYLD_ROOT_PATH + unset DYLD_IMAGE_SUFFIX LD_LIBRARY_PATH LD_PRELOAD LD_AUDIT + JERBOA_NATIVE_SENTINEL_MARKER="$native_marker" \ + JERBOA_DEV_NATIVE=1 JERBOA_NATIVE_LIB="$native_lib" \ + "$jerbuild" exec --libdirs "$root/lib:$jh/lib" \ + "$tmp/native-probe.ss" >/dev/null + ) + [ -e "$native_marker" ] || { + echo "ffi-native-loader: canonical unified native control was not loaded" >&2 + exit 1 + } + rm -f "$native_marker" + + if JERBOA_NATIVE_SENTINEL_MARKER="$native_marker" \ + JERBOA_NATIVE_LIB="$native_lib" \ + "$jerbuild" exec --libdirs "$root/lib:$jh/lib" \ + "$tmp/native-probe.ss" >/dev/null 2>&1; then + echo "ffi-native-loader: unified native load succeeded without dev opt-in" >&2 + exit 1 + fi + [ ! -e "$native_marker" ] || { + echo "ffi-native-loader: unified native constructor ran without dev opt-in" >&2 + exit 1 + } fi -[ ! -e "$native_marker" ] || { - echo "ffi-native-loader: unified native constructor ran without dev opt-in" >&2 - exit 1 -} echo "ffi-native-loader-security: pass" --- a/test/test-security-regressions.ss +++ b/test/test-security-regressions.ss @@ -6,6 +6,7 @@ (jsh mux-proto) (jsh mux-auth) (jsh mux-session) + (jsh mux-screen) (jsh mux-transport) (only (jsh mux-client) mux-client-set-dynamic-port! @@ -41,6 +42,16 @@ (define (read-string path) (call-with-input-file path get-string-all)) +(define (string-search? haystack needle) + (let ([hlen (string-length haystack)] + [nlen (string-length needle)]) + (let loop ([i 0]) + (cond + [(= nlen 0) #t] + [(> (+ i nlen) hlen) #f] + [(string=? (substring haystack i (+ i nlen)) needle) #t] + [else (loop (+ i 1))])))) + (define c-symlink (foreign-procedure "symlink" (string string) int)) (define c-rmdir (foreign-procedure "rmdir" (string) int)) @@ -408,6 +419,19 @@ (= (ffi-file-type link-path 0) 0) (string=? (read-string link-path) "replacement"))) +(let* ([windows (list (make-mux-window 0 "alpha" '() 0) + (make-mux-window 1 "beta" '() 0) + (make-mux-window 2 "gamma" '() 0) + (make-mux-window 3 "current" '() 0) + (make-mux-window 4 "delta" '() 0))] + [session (make-mux-session 0 "narrow-session" windows 3 0 5 '())] + [bar (render-status-bar session 30)]) + (check "narrow mux status bar keeps active buffer name" + (string-search? bar "3:current*")) + (check "narrow mux status bar drops load/time before buffer names" + (and (not (string-search? bar "\x1B;[32;40m")) + (not (string-search? bar "\x1B;[33;40m"))))) + (let* ([pane (make-mux-pane 0 -1 0 80 24 #f (make-vt 80 24) (make-ring))] [window (make-mux-window 0 "main" (list pane) 0)] [session (make-mux-session 0 "session" (list window) 0 0 1 '())]) --- a/tools/select-features.sh +++ b/tools/select-features.sh @@ -241,11 +241,15 @@ draw_tui() { } run_tui() { - [ -t 0 ] && [ -t 1 ] || { + if ! { [ -t 0 ] && [ -t 1 ]; }; then + if [ -f "$OUT_FILE" ]; then + write_config + exit 0 + fi echo "ERROR: interactive feature selection needs a TTY" >&2 echo "Use 'make features-all', 'make features-minimal', or set JSH_FEATURES=..." >&2 exit 1 - } + fi local cursor=0 key rest trap 'printf "\033[?25h"; exit 130' INT TERM