Harden nREPL auth and musl builds
ober
44dd2b20acef8470e8cb52abcca7fcb1347d1a2c
--- a/lib/jerboa/build/musl.ss +++ b/lib/jerboa/build/musl.ss @@ -70,7 +70,7 @@ "Search PATH for an executable, return full path or #f" (try (let-values ([(to-stdin from-stdout from-stderr pid) (open-process-ports - (format "which '~a' 2>/dev/null" name) + (format "which ~a 2>/dev/null" (%musl-shell-quote name)) (buffer-mode block) (native-transcoder))]) (close-port to-stdin) @@ -96,10 +96,17 @@ "Return the musl sysroot directory" (let ([gcc (musl-gcc-path)]) (if gcc - (let ([result (with-output-to-string - (lambda () - (system (format "~a -print-sysroot 2>/dev/null" gcc))))]) - (let ([trimmed (%musl-string-trim-right result)]) + (let-values ([(to-stdin from-stdout from-stderr pid) + (open-process-ports + (format "~a -print-sysroot 2>/dev/null" + (%musl-shell-quote gcc)) + (buffer-mode block) + (native-transcoder))]) + (close-port to-stdin) + (close-port from-stderr) + (let* ([line (get-line from-stdout)] + [trimmed (if (eof-object? line) "" (%musl-string-trim-right line))]) + (close-port from-stdout) (if (string=? trimmed "") ;; Fallback: standard musl location "/usr/lib/x86_64-linux-musl" @@ -269,21 +276,17 @@ [liblz4 (musl-liblz4-path)] ;; Object files as space-separated string - [objs (apply string-append - (map (lambda (o) (format " '~a'" o)) - object-files))] + [objs (%musl-join-quoted object-files)] ;; Chez runtime archives [chez-libs (apply string-append (filter values - (list (format " '~a'" libkernel) - (and libz (format " '~a'" libz)) - (and liblz4 (format " '~a'" liblz4)))))] + (list (format " ~a" (%musl-shell-quote libkernel)) + (and libz (format " ~a" (%musl-shell-quote libz))) + (and liblz4 (format " ~a" (%musl-shell-quote liblz4))))))] ;; User static libraries - [user-libs (apply string-append - (map (lambda (a) (format " '~a'" a)) - static-libs))] + [user-libs (%musl-join-quoted static-libs)] ;; Standard libraries needed by Chez runtime [std-libs "-lm -lrt -lpthread"] @@ -294,14 +297,14 @@ "-static" "-static-pie -Wl,-z,relro,-z,now")]) - (format "~a ~a~a~a~a ~a -o '~a'" - gcc + (format "~a ~a~a~a~a ~a -o ~a" + (%musl-shell-quote gcc) link-flags objs ;; Application + Chez main.o + static_boot.o chez-libs ;; Chez runtime archives user-libs ;; User static libs std-libs ;; Math, rt, pthreads - output-path))) + (%musl-shell-quote output-path)))) ;; ========== High-Level Build ========== @@ -343,8 +346,7 @@ [no-harden? (%musl-kwarg 'no-harden: opts #f)] ;; Build directory - [build-dir (format "/tmp/jerboa-musl-~a" - (time-second (current-time)))] + [build-dir (%musl-temp-dir)] [gcc (musl-gcc-path)] [scheme-h-dir (let ([p (musl-scheme-h-path)]) ;; directory containing scheme.h @@ -352,7 +354,7 @@ [chez-main-o (musl-main-o-path)]) ;; Create build directory - (system (format "mkdir -p '~a'" build-dir)) + (system (format "mkdir -p -- ~a" (%musl-shell-quote build-dir))) (dynamic-wind (lambda () #f) @@ -361,7 +363,10 @@ ;; Step 1: Compile Scheme to .so (when verbose? (printf "[1/5] Compiling Scheme source: ~a~n" source-path)) (let ([so-path (format "~a/program.so" build-dir)]) - (parameterize ([optimize-level opt-level] + (parameterize ([library-directories + (append (%musl-normalize-libdirs libdirs) + (library-directories))] + [optimize-level opt-level] [compile-imported-libraries #t] [generate-inspector-information #f]) (compile-program source-path so-path)) @@ -384,7 +389,7 @@ ;; Step 4: Compile C files (when verbose? (display "[4/5] Compiling C...\n")) (let* ([static-boot-o (format "~a/static_boot.o" build-dir)] - [include-flag (format "-I'~a'" scheme-h-dir)] + [include-flag (format "-I~a" (%musl-shell-quote scheme-h-dir))] [harden-cflags (if no-harden? "" (string-append @@ -398,9 +403,13 @@ " -fcf-protection=full" "")))] [compile-cmd - (format "~a -c -O2~a ~a ~a -o '~a' '~a'" - gcc harden-cflags include-flag extra-cflags - static-boot-o static-boot-c)] + (format "~a -c -O2~a ~a ~a -o ~a ~a" + (%musl-shell-quote gcc) + harden-cflags + include-flag + (%musl-cflags-string extra-cflags) + (%musl-shell-quote static-boot-o) + (%musl-shell-quote static-boot-c))] [rc (begin (when verbose? (printf " ~a~n" compile-cmd)) (system compile-cmd))]) @@ -416,10 +425,13 @@ build-dir (%musl-path-root (%musl-path-last c-file)))]) - (let ([cmd (format "~a -c -O2~a ~a ~a -o '~a' '~a'" - gcc harden-cflags - include-flag extra-cflags - o-file c-file)]) + (let ([cmd (format "~a -c -O2~a ~a ~a -o ~a ~a" + (%musl-shell-quote gcc) + harden-cflags + include-flag + (%musl-cflags-string extra-cflags) + (%musl-shell-quote o-file) + (%musl-shell-quote c-file))]) (when verbose? (printf " ~a~n" cmd)) (unless (= (system cmd) 0) (error 'build-musl-binary @@ -449,13 +461,13 @@ ;; Success (when verbose? (printf "~nBuilt: ~a~n" output-path) - (system (format "ls -lh '~a'" output-path)) - (system (format "file '~a'" output-path))) + (system (format "ls -lh -- ~a" (%musl-shell-quote output-path))) + (system (format "file -- ~a" (%musl-shell-quote output-path)))) output-path))))))) ;; Cleanup (lambda () - (system (format "rm -rf '~a'" build-dir)))))) + (system (format "rm -rf -- ~a" (%musl-shell-quote build-dir))))))) ;; ========== C Code Generation ========== @@ -537,6 +549,50 @@ (cond [(or (null? lst) (null? (cdr lst))) default] [(eq? (car lst) key) (cadr lst)] [else (loop (cddr lst))])))) + + (def (%musl-shell-quote value) + "Return VALUE as one POSIX shell word." + (let* ([s (if (string? value) value (format "~a" value))] + [out (open-output-string)]) + (display "'" out) + (let loop ([i 0]) + (unless (= i (string-length s)) + (let ([ch (string-ref s i)]) + (if (char=? ch #\') + (display "'\\''" out) + (write-char ch out))) + (loop (+ i 1)))) + (display "'" out) + (get-output-string out))) + + (def (%musl-join-quoted values) + (apply string-append + (map (lambda (value) + (string-append " " (%musl-shell-quote value))) + values))) + + (def (%musl-cflags-string value) + (cond + [(not value) ""] + [(string? value) value] + [(list? value) (%musl-join-quoted value)] + [else (error 'build-musl-binary "extra-cflags must be string or list" value)])) + + (def (%musl-normalize-libdirs value) + (cond + [(not value) '()] + [(string? value) + (filter (lambda (s) (not (string=? s ""))) + (%musl-string-split value #\:))] + [(list? value) value] + [else (error 'build-musl-binary "libdirs must be string or list" value)])) + + (def (%musl-temp-dir) + (let loop () + (let ([path (format "/tmp/jerboa-musl-~a-~a" + (time-second (current-time)) + (random 1000000000))]) + (if (file-exists? path) (loop) path)))) (def (%musl-path-last path) "Return the last component of a path" --- a/src/.jerbuild-hashes +++ b/src/.jerbuild-hashes @@ -1 +1 @@ -(("src/std/nrepl.ss" . "5EF476A1FF54387C")) +(("src/std/nrepl.ss" . "50A5D3E240D346FD")) --- a/src/std/nrepl.ss +++ b/src/std/nrepl.ss @@ -303,6 +303,22 @@ "status" (list "error" "auth-required" "done") "ex" "auth-required: include 'token' field or send op=auth first"))) +(def (auth-required-op? op) + (or (string=? op "eval") + (string=? op "load-file") + (string=? op "eval-timed") + (string=? op "inspect-start") + (string=? op "type-info") + (string=? op "macroexpand") + (string=? op "macroexpand-1") + (string=? op "macroexpand-all") + (string=? op "format-code") + (string=? op "format-edn") + (string=? op "undef") + (string=? op "test") + (string=? op "test-all") + (string=? op "test-ns"))) + (def (handle-auth msg out) (if (msg-authed? msg) (send-response! out (make-response msg "status" (list "done"))) @@ -1359,12 +1375,9 @@ (def (handle-message msg out) (let ((op (dict-ref msg "op" ""))) (cond - ;; Auth (P1.1): explicit op + gate for eval-class ops + ;; Auth (P1.1): explicit op + gate for code-evaluating/mutating ops ((string=? op "auth") (handle-auth msg out)) - ((and (or (string=? op "eval") - (string=? op "load-file") - (string=? op "eval-timed")) - (not (msg-authed? msg))) + ((and (auth-required-op? op) (not (msg-authed? msg))) (send-auth-required! msg out)) ;; Base ops ((string=? op "clone") (handle-clone msg out)) --- a/tests/test-musl.ss +++ b/tests/test-musl.ss @@ -42,7 +42,7 @@ (define (run-test name thunk) (set! test-count (+ test-count 1)) - (let ([result (guard (e [#t #f]) (thunk) #t)]) + (let ([result (guard (e [#t #f]) (thunk))]) (when result (set! pass-count (+ pass-count 1))) (display-result name result))) @@ -134,10 +134,13 @@ (display-test-header "Link Command Generation") +(define (valid-musl-setup?) + (eq? (car (validate-musl-setup)) 'ok)) + (run-test "musl-link-command returns string" (lambda () (guard (e [#t #f]) - (when (musl-available?) + (when (valid-musl-setup?) (let ([cmd (musl-link-command "/tmp/test" '("/tmp/main.o") @@ -147,7 +150,7 @@ (run-test "link command contains -static" (lambda () (guard (e [#t #f]) - (when (musl-available?) + (when (valid-musl-setup?) (let ([cmd (musl-link-command "/tmp/test" '("/tmp/main.o") @@ -157,7 +160,7 @@ (run-test "link command contains -nostdlib" (lambda () (guard (e [#t #f]) - (when (musl-available?) + (when (valid-musl-setup?) (let ([cmd (musl-link-command "/tmp/test" '("/tmp/main.o") --- a/tests/test-nrepl-auth.ss +++ b/tests/test-nrepl-auth.ss @@ -10,6 +10,7 @@ ;;; never delivered any response to a client and these would have timed ;;; out): ;;; W1 eval without token → status contains auth-required +;;; W1b eval-like ops 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 @@ -137,6 +138,14 @@ [else (scan (cdr ds))]))]) (or hit (loop (- n 1))))]))]))) +(define (check-op-auth-required port op code id) + (let ([fd (connect-with-timeout port)]) + (send-dict fd `(("op" . ,op) ("code" . ,code) ("id" . ,id))) + (let ([st (await-field fd "status" 5)]) + (check (string-append id ": " op " without token -> auth-required") + (and (list? st) (and (member "auth-required" st) #t)) #t)) + (tcp-close fd))) + (define (slurp-file path) (let ([p (open-input-file path)]) (let loop ([chars '()]) @@ -176,6 +185,11 @@ (and (list? st) (and (member "auth-required" st) #t)) #t)) (tcp-close fd)) +(check-op-auth-required p "inspect-start" "(+ 1 2)" "W1b") +(check-op-auth-required p "type-info" "(+ 1 2)" "W1c") +(check-op-auth-required p "macroexpand" "(+ 1 2)" "W1d") +(check-op-auth-required p "format-code" "(+ 1 2)" "W1e") + (let ([fd (connect-with-timeout p)]) (send-dict fd `(("op" . "auth") ("token" . "wrong") ("id" . "w2"))) (let ([st (await-field fd "status" 5)])