Merge security/p4.2b-nrepl-macos-abi
ober
6364119aa161aef50bd201c9e818cc02e9e01dba
--- a/src/std/nrepl.ss +++ b/src/std/nrepl.ss @@ -77,7 +77,13 @@ (format "~a" (car kv))) (cdr kv))) (hash->list obj))) - (sorted (sort (lambda (a b) (string<? (car a) (car b))) pairs))) + ;; NOTE: (std sort) is imported above, which uses Gerbil-style + ;; arg order (sort list pred), not Chez's (sort pred list). + ;; The previous arg order silently swallowed every hashtable + ;; response — bencode-write threw, handle-client's guard + ;; encoded the error reply through the same broken path, + ;; and the worker died silently. The client just timed out. + (sorted (sort pairs (lambda (a b) (string<? (car a) (car b)))))) (for-each (lambda (pair) (bencode-write (car pair) port) (bencode-write (cdr pair) port)) @@ -1493,13 +1499,26 @@ (def (get-errno) (foreign-ref 'int (c-errno-location) 0)) (def EINTR 4) -(def *freebsd?* (memq (machine-type) '(a6fb ta6fb i3fb ti3fb arm64fb))) + +;; Constants below differ between Linux (the false branch) and BSD-derived +;; OSes (FreeBSD + macOS, the true branch). The name *freebsd?* is kept +;; for source-history compatibility; semantically it means "BSD-like". +;; Without this, on macOS arm64 set-nonblocking! sets O_EXCL (0x800) by +;; mistake, the EAGAIN check never matches the real EAGAIN (35), and +;; setsockopt for SO_REUSEADDR aims at the wrong level — all of which +;; caused the nREPL server to read requests fine but never deliver +;; responses to clients. +(def *freebsd?* + (let ([mt (symbol->string (machine-type))]) + (or (memq (machine-type) '(a6fb ta6fb i3fb ti3fb arm64fb)) + ;; macOS machine types end in "osx" (e.g. tarm64osx, ta6osx). + (let ([n (string-length mt)]) + (and (>= n 3) (string=? (substring mt (- n 3) n) "osx")))))) (def EAGAIN (if *freebsd?* 35 11)) (def F_GETFL 3) (def F_SETFL 4) -(def O_NONBLOCK - (if (memq (machine-type) '(a6fb ta6fb i3fb ti3fb arm64fb)) #x4 #x800)) +(def O_NONBLOCK (if *freebsd?* #x4 #x800)) (def AF_INET 2) (def SOCK_STREAM 1) @@ -1519,7 +1538,14 @@ (bytevector-u8-set! buf 0 16) (bytevector-u8-set! buf 1 AF_INET)) (bytevector-u16-native-set! buf 0 AF_INET)) - (bytevector-u16-set! buf 2 (c-htons port) 'big) + ;; sin_port. The previous code did `(bytevector-u16-set! buf 2 (c-htons port) 'big)` + ;; which is a DOUBLE byte-swap on a little-endian host: htons already + ;; converts host→network, and writing with `'big` then byte-swaps the + ;; already-network-order value back to host order in memory. The + ;; kernel reads it in network order, so it landed on the wrong port + ;; (e.g. asking for 12345 bound 14640). Drop the htons; `'big` alone + ;; is correct since network byte order == big-endian. + (bytevector-u16-set! buf 2 port 'big) (bytevector-u8-set! buf 4 127) (bytevector-u8-set! buf 5 0) (bytevector-u8-set! buf 6 0) --- a/tests/test-nrepl-auth.ss +++ b/tests/test-nrepl-auth.ss @@ -1,22 +1,22 @@ ;;; tests/test-nrepl-auth.ss -;;; P1.1 — nREPL eval-surface auth: file-lifecycle security properties. +;;; P1.1: nREPL eval surface requires per-session token auth. ;;; -;;; The wire-level auth-gate behavior is covered by code review (the dispatch -;;; in handle-message routes eval/load-file/eval-timed through msg-authed?). -;;; Verifying it end-to-end requires a working nREPL client, but the existing -;;; nrepl socket FFI has pre-existing macOS-arm64 issues (wrong O_NONBLOCK, -;;; EAGAIN, SOL_SOCKET constants, htons double-byte-swap) that are out of -;;; scope for this patch. We verify the on-disk side here, which is the -;;; tamper-relevant surface — token confidentiality and cleanup. +;;; File-lifecycle: +;;; T1 .nrepl-token is created on start (auth on) +;;; T2 .nrepl-token mode is 0600 +;;; T3 .nrepl-token is removed on nrepl-stop! ;;; -;;; T1 auth ON → .nrepl-token created, contents are 64 hex chars -;;; T2 auth ON → .nrepl-token mode is 0600 (no group/other access) -;;; T3 auth OFF → .nrepl-token NOT created -;;; T4 stop → .nrepl-token removed -;;; T5 restart → fresh token (entropy renewed) +;;; Wire-level (depends on the macOS-arm64 ABI fixes — pre-fix the nREPL +;;; never delivered any response to a client and these would have timed +;;; out): +;;; W1 eval without token → status contains auth-required +;;; W2 auth with wrong token → status contains auth-required +;;; W3 auth with correct token → status done, no auth-required +;;; W4 eval with inline correct token → returns value (import (chezscheme) - (std nrepl)) + (std nrepl) + (std net tcp-raw)) (define pass-count 0) (define fail-count 0) @@ -35,8 +35,107 @@ (display " got: ") (write got) (newline) (display " expected: ") (write expected) (newline)]))])) -(define token-path (string-append (current-directory) "/.nrepl-token")) -(define port-path (string-append (current-directory) "/.nrepl-port")) +;; ---------- minimal bencode encoder (string-only dict) ---------- +(define (bencode-str s port) + (let ([bv (string->utf8 s)]) + (put-bytevector port (string->utf8 (number->string (bytevector-length bv)))) + (put-u8 port (char->integer #\:)) + (put-bytevector port bv))) + +(define (bencode-dict alist) + (let-values ([(port extract) (open-bytevector-output-port)]) + (put-u8 port (char->integer #\d)) + (let ([sorted (list-sort (lambda (a b) (string<? (car a) (car b))) alist)]) + (for-each (lambda (kv) (bencode-str (car kv) port) (bencode-str (cdr kv) port)) + sorted)) + (put-u8 port (char->integer #\e)) + (extract))) + +;; ---------- minimal bencode decoder ---------- +(define (decode bv pos) + (let ([b (bytevector-u8-ref bv pos)]) + (cond + [(= b (char->integer #\i)) (decode-int bv (+ pos 1))] + [(= b (char->integer #\l)) (decode-list bv (+ pos 1))] + [(= b (char->integer #\d)) (decode-dict bv (+ pos 1))] + [(and (>= b (char->integer #\0)) (<= b (char->integer #\9))) + (decode-str bv pos)] + [else (error 'decode "unexpected byte" b pos)]))) + +(define (decode-int bv pos) + (let loop ([acc '()] [pos pos]) + (let ([b (bytevector-u8-ref bv pos)]) + (if (= b (char->integer #\e)) + (cons (string->number (list->string (reverse acc))) (+ pos 1)) + (loop (cons (integer->char b) acc) (+ pos 1)))))) + +(define (decode-str bv pos) + (let loop ([acc '()] [pos pos]) + (let ([b (bytevector-u8-ref bv pos)]) + (if (= b (char->integer #\:)) + (let* ([len (string->number (list->string (reverse acc)))] + [body-start (+ pos 1)] + [out (make-bytevector len)]) + (do ([i 0 (+ i 1)]) ((= i len) (cons (utf8->string out) (+ body-start len))) + (bytevector-u8-set! out i (bytevector-u8-ref bv (+ body-start i))))) + (loop (cons (integer->char b) acc) (+ pos 1)))))) + +(define (decode-list bv pos) + (let loop ([acc '()] [pos pos]) + (let ([b (bytevector-u8-ref bv pos)]) + (if (= b (char->integer #\e)) + (cons (reverse acc) (+ pos 1)) + (let ([v (decode bv pos)]) (loop (cons (car v) acc) (cdr v))))))) + +(define (decode-dict bv pos) + (let loop ([acc '()] [pos pos]) + (let ([b (bytevector-u8-ref bv pos)]) + (if (= b (char->integer #\e)) + (cons (reverse acc) (+ pos 1)) + (let* ([k (decode bv pos)] [v (decode bv (cdr k))]) + (loop (cons (cons (car k) (car v)) acc) (cdr v))))))) + +;; ---------- TCP/protocol helpers ---------- +(define (connect-with-timeout port) + (let ([fd (tcp-connect "127.0.0.1" port)]) + (tcp-set-timeout fd 2 2) + fd)) + +(define (send-dict fd alist) (tcp-write fd (bencode-dict alist))) + +(define (read-chunk fd) + (let* ([buf (make-bytevector 65536)] + [n (tcp-read fd buf 65536)]) + (cond + [(or (eof-object? n) (not (number? n)) (<= n 0)) #f] + [else + (let ([out (make-bytevector n)]) + (do ([i 0 (+ i 1)]) ((= i n) out) + (bytevector-u8-set! out i (bytevector-u8-ref buf i))))]))) + +(define (parse-all bv) + (let loop ([pos 0] [acc '()]) + (cond + [(>= pos (bytevector-length bv)) (reverse acc)] + [else (let ([r (decode bv pos)]) (loop (cdr r) (cons (car r) acc)))]))) + +(define (dict-get d k) (let ([p (assoc k d)]) (and p (cdr p)))) + +(define (await-field fd key max-reads) + (let loop ([n max-reads]) + (cond + [(zero? n) #f] + [else + (let ([chunk (read-chunk fd)]) + (cond + [(not chunk) (loop (- n 1))] + [else + (let ([hit (let scan ([ds (parse-all chunk)]) + (cond + [(null? ds) #f] + [(dict-get (car ds) key) (dict-get (car ds) key)] + [else (scan (cdr ds))]))]) + (or hit (loop (- n 1))))]))]))) (define (slurp-file path) (let ([p (open-input-file path)]) @@ -46,88 +145,63 @@ [(eof-object? c) (close-port p) (list->string (reverse chars))] [else (loop (cons c chars))]))))) -(define (hex-char? c) - (or (and (char>=? c #\0) (char<=? c #\9)) - (and (char>=? c #\a) (char<=? c #\f)) - (and (char>=? c #\A) (char<=? c #\F)))) +(define (file-mode-600? path) + ;; Read mode via stat, last 3 digits must be 600. + (let-values ([(stdin stdout stderr pid) + (open-process-ports + (string-append "stat -f '%Op' " path " 2>/dev/null || stat -c '%a' " path) + (buffer-mode block) (native-transcoder))]) + (close-port stdin) (close-port stderr) + (let ([out (get-line stdout)]) + (close-port stdout) + (and (string? out) + (let* ([n (string-length out)] [start (max 0 (- n 3))]) + (= 600 (or (string->number (substring out start n)) -1))))))) -(define (all-hex? s) - (let loop ([i 0]) - (cond - [(= i (string-length s)) #t] - [(hex-char? (string-ref s i)) (loop (+ i 1))] - [else #f]))) - -;; chmod-readable mode via stat: invoke `stat -f %Op` on macOS / `stat -c %a` on Linux. -;; Returns the integer octal of the perm bits (e.g. 600), or #f on failure. -(define (file-mode path) - (let-values ([(in out) (open-string-output-port)]) - (let ([fmt (case (system-machine-os) - [(macos darwin freebsd) "-f"] - [else "-c"])] - [spec (case (system-machine-os) - [(macos darwin freebsd) "%Op"] - [else "%a"])]) - ;; Use system call via open-process-ports - (let-values ([(stdin stdout stderr pid) - (open-process-ports - (string-append "stat " fmt " " spec " " path) - (buffer-mode block) - (native-transcoder))]) - (close-port stdin) - (close-port stderr) - (let ([out (get-line stdout)]) - (close-port stdout) - (and (string? out) - ;; On macOS the value is full mode like "100600"; take last 3 chars. - (let* ([n (string-length out)] - [start (max 0 (- n 3))]) - (string->number (substring out start n))))))))) - -(define (system-machine-os) - (let ([mt (symbol->string (machine-type))]) - (cond - [(and (>= (string-length mt) 3) - (string=? (substring mt (- (string-length mt) 3) (string-length mt)) "osx")) - 'macos] - [(and (>= (string-length mt) 2) - (string=? (substring mt (- (string-length mt) 2) (string-length mt)) "fb")) - 'freebsd] - [else 'linux]))) - -;; Make sure no stale state. +(define token-path (string-append (current-directory) "/.nrepl-token")) +(define port-path (string-append (current-directory) "/.nrepl-port")) (when (file-exists? token-path) (delete-file token-path)) (when (file-exists? port-path) (delete-file port-path)) -;; ============ T1, T2: auth ON ============ -(nrepl-start! 0 #t) - -(check "T1a: .nrepl-token exists after start (auth on)" - (file-exists? token-path) #t) +;; ============ File-lifecycle (T1-T3) + Wire (W1-W4) ============ +(define p (nrepl-start! 0 #t)) +(check "T1: .nrepl-token exists after start" (file-exists? token-path) #t) +(check "T2: .nrepl-token mode is 600" (file-mode-600? token-path) #t) +(define tok (slurp-file token-path)) + +(let ([fd (connect-with-timeout p)]) + (send-dict fd `(("op" . "eval") ("code" . "(+ 1 2)") ("id" . "w1"))) + (let ([st (await-field fd "status" 5)]) + (check "W1: eval without token → auth-required" + (and (list? st) (and (member "auth-required" st) #t)) #t)) + (tcp-close fd)) + +(let ([fd (connect-with-timeout p)]) + (send-dict fd `(("op" . "auth") ("token" . "wrong") ("id" . "w2"))) + (let ([st (await-field fd "status" 5)]) + (check "W2: auth wrong token → auth-required" + (and (list? st) (and (member "auth-required" st) #t)) #t)) + (tcp-close fd)) + +(let ([fd (connect-with-timeout p)]) + (send-dict fd `(("op" . "auth") ("token" . ,tok) ("id" . "w3"))) + (let ([st (await-field fd "status" 5)]) + (check "W3: auth correct token → done, no auth-required" + (and (list? st) (member "done" st) (not (member "auth-required" st)) #t) #t)) + (tcp-close fd)) + +(let ([fd (connect-with-timeout p)]) + (send-dict fd `(("op" . "eval") ("code" . "(+ 41 1)") + ("token" . ,tok) ("id" . "w4"))) + (let ([v (await-field fd "value" 10)]) + (check "W4: eval with inline token → value 42" v "42")) + (tcp-close fd)) -(let ([tok (slurp-file token-path)]) - (check "T1b: token is 64 chars" (string-length tok) 64) - (check "T1c: token is all hex" (all-hex? tok) #t)) - -(check "T2: token file mode is 600" - (file-mode token-path) 600) - -(define first-token (slurp-file token-path)) - -;; ============ T3: auth OFF (after stop, fresh start) ============ -;; Run T3 BEFORE stop+restart to avoid thread-cleanup interactions in nrepl -;; (start/stop/start sequence has known issues unrelated to auth). (nrepl-stop!) +(check "T3: .nrepl-token removed on nrepl-stop!" (file-exists? token-path) #f) -;; ============ T4: cleanup ============ -(check "T4: .nrepl-token removed on stop" - (file-exists? token-path) #f) -(check "T4b: first token was non-empty" - (positive? (string-length first-token)) #t) - -;; Final cleanup (when (file-exists? token-path) (delete-file token-path)) (when (file-exists? port-path) (delete-file port-path)) -(printf "\nnREPL auth (file-lifecycle): ~a passed, ~a failed\n" pass-count fail-count) +(printf "\nnREPL auth: ~a passed, ~a failed\n" pass-count fail-count) (exit (if (zero? fail-count) 0 1))