commit 9fa634dfaef8457ee8f022da7f08db32e81f7002 from: mtmn date: Thu Sep 10 10:39:33 2026 UTC fixes commit - 85714d28e5bc0b9c146d3fff8bc0f65dc42f8a7b commit + 9fa634dfaef8457ee8f022da7f08db32e81f7002 blob - 2048da2ac2f1da716005271ddb8a5dab5b268efa blob + 181b9895367c7bca22f33979835a3a9ef09aa746 --- bin/pisol.scm +++ bin/pisol.scm @@ -8,7 +8,7 @@ (loop (cddr remaining) (cadr remaining) config)) ((and (pair? (cdr remaining)) (string=? (car remaining) "--config")) (loop (cddr remaining) project (cadr remaining))) - (else (error 'pisol "unknown or incomplete internal option" (car remaining)))))) + (else (error 'pisol "Unknown option." (car remaining)))))) (handle-exceptions exn (begin @@ -18,7 +18,7 @@ (exit 1)) (receive (project-argument config-argument) (parse (command-line-arguments)) (let* ((project (or (canonical-directory (or project-argument (current-directory))) - (error 'pisol "project is not a directory" project-argument))) + (error 'pisol "The project is not a directory." project-argument))) (config (or config-argument (get-environment-variable "ISOLATE_EXTRA_CONFIG") (string-append project "/.isolate")))) blob - bf7ca4885a0750173c4c4410aa54dc0208b460c9 blob + 35c5bafa47f3f55ec4b28d3c41cdf6b9b317fc75 --- src/pisol/core.scm +++ src/pisol/core.scm @@ -6,7 +6,7 @@ configuration-local-outbound-ports configuration-source-style configuration-dirty? add-directory! remove-directory! add-port! remove-port! port-valid? canonical-directory shell-quote - string-prefix? trim read-text) + string-prefix? trim read-text decimal-string->number) (import scheme (chicken base) (chicken condition) (chicken file) (chicken file posix) (chicken format) (chicken io) (chicken process) (chicken pathname) (chicken process-context) (chicken port) (chicken sort) @@ -49,16 +49,84 @@ (right (- end 1)) (substring text start end)))))) + ;; ASCII-only decimal check. char-numeric? accepts Unicode digits. Matching + ;; the bash validator ([0-9]+) instead. + (define (ascii-digit? character) + (and (char>=? character #\0) (char<=? character #\9))) + + (define (decimal-string->number text) + (and (string? text) + (> (string-length text) 0) + (let loop ((index 0)) + (or (= index (string-length text)) + (and (ascii-digit? (string-ref text index)) + (loop (+ index 1))))) + (string->number text))) + + (define (nonempty-env name) + (let ((value (get-environment-variable name))) + (and (string? value) (> (string-length value) 0) value))) + + (define (join-components parts) + (string-intersperse parts "/")) + + (define (lexical-normalize absolute) + (let ((parts (string-split absolute "/" #f))) + (let loop ((rest parts) (stack '())) + (cond ((null? rest) + (if (null? stack) + "/" + (string-append "/" (join-components (reverse stack))))) + ((or (string=? (car rest) ".") (string=? (car rest) "")) + (loop (cdr rest) stack)) + ((string=? (car rest) "..") + (loop (cdr rest) (if (null? stack) '() (cdr stack)))) + (else (loop (cdr rest) (cons (car rest) stack))))))) + + (define (prefix-string reversed-components) + (if (null? reversed-components) + "/" + (string-append "/" (join-components (reverse reversed-components))))) + + ;; Resolve PATH without changing the working directory. The old code used + ;; change-directory inside dynamic-wind. That mutates global state and is + ;; unsafe with threads. This version normalises the path, then resolves + ;; symlinks. A symlink into the project cannot hide behind an outside + ;; string. (define (canonical-directory path) (and (string? path) (> (string-length path) 0) - (directory? path) - (let ((here (current-directory))) - (handle-exceptions _ #f - (dynamic-wind - (lambda () (change-directory path)) - (lambda () (current-directory)) - (lambda () (change-directory here))))))) + (handle-exceptions _ #f + (let ((absolute (if (string-prefix? "/" path) + (lexical-normalize path) + (lexical-normalize + (string-append (current-directory) "/" path))))) + (let resolve ((current absolute) (depth 0)) + (when (> depth 40) + (error 'canonical-directory "Too many symlinks in the path." path)) + (let ((parts (string-split current "/" #f))) + (let walk ((done '()) (rest parts)) + (if (null? rest) + (let ((final (prefix-string done))) + (and (directory? final) final)) + (let* ((prefix (prefix-string (cons (car rest) done))) + (target (handle-exceptions _ #f + (read-symbolic-link prefix)))) + (if (not target) + (walk (cons (car rest) done) (cdr rest)) + (let* ((parent (prefix-string done)) + (absolute-target + (if (string-prefix? "/" target) + (lexical-normalize target) + (lexical-normalize + (string-append parent "/" target)))) + (suffix (cdr rest)) + (combined (if (null? suffix) + absolute-target + (string-append absolute-target "/" + (join-components suffix))))) + (resolve (lexical-normalize combined) + (+ depth 1))))))))))))) (define (path-within? path root) (or (string=? path root) @@ -146,8 +214,13 @@ "'\\''" (string character)))))))) + ;; read-string returns EOF on an empty file. Callers expect a string. + ;; Coerce EOF to "". (define (read-text path) - (call-with-input-file path (lambda (port) (read-string #f port)))) + (call-with-input-file path + (lambda (port) + (let ((text (read-string #f port))) + (if (eof-object? text) "" text))))) (define (canonical-source? text) (let ((text (trim text))) @@ -158,82 +231,114 @@ (define (nul-strings text) (string-split text "\x00" #f)) - (define (evaluate-config path) - (let ((script "args=(); source \"$1\"; if ((${#args[@]})); then printf '%s\\0' \"${args[@]}\"; fi")) - (receive (in out pid err) (process* "bash" (list "-c" script "pisol-config" path)) - (dynamic-wind - void - (lambda () - (close-output-port out) - ;; Drain both pipes before waiting on the child: a config that - ;; emits more than a pipe buffer of output would otherwise block - ;; bash on write while this process blocks in process-wait, - ;; deadlocking pisol. - (let ((text (read-string #f in)) - (raw-err (read-string #f err))) - (receive (_ normal? status) (process-wait pid) - (unless (and normal? (zero? status)) - (let ((message (if (eof-object? raw-err) - "configuration evaluation failed" - (trim raw-err)))) - (error 'load-configuration message path)))) - (if (or (eof-object? text) (zero? (string-length text))) - '() - (nul-strings text)))) - (lambda () - (close-input-port in) - (close-input-port err)))))) + (define (stderr-template) + (string-append (or (nonempty-env "TMPDIR") "/tmp") "/pisol-stderr.XXXXXX")) + ;; Evaluate config CONTENT that is already read. load-configuration reads + ;; the file once and passes the text. This removes a race where the file + ;; changes between the style check and sourcing. Stderr goes to a temp + ;; file, so only stdout uses a pipe. Draining two pipes in turn can still + ;; deadlock when both fill. + (define (evaluate-text content path-for-errors) + (let ((script (string-append + "exec 2>\"$1\"; shift; " + "args=(); eval \"$1\"; " + "if ((${#args[@]})); then printf '%s\\0' \"${args[@]}\"; fi"))) + (receive (tmp-fd tmp-path) (file-mkstemp (stderr-template)) + (file-close tmp-fd) + (handle-exceptions exn + (begin (when (file-exists? tmp-path) (delete-file* tmp-path)) + (abort exn)) + (receive (in out pid err) (process* "bash" (list "-c" script "pisol-config" tmp-path content)) + (dynamic-wind + void + (lambda () + (close-output-port out) + ;; Redirected to a file, so the err pipe carries nothing. + (handle-exceptions _ #f (read-string #f err)) + (let ((text (read-string #f in))) + (receive (_ normal? status) (process-wait pid) + (let* ((raw-err (handle-exceptions _ "" (read-text tmp-path))) + (message (let ((trimmed (if (string? raw-err) (trim raw-err) ""))) + (if (zero? (string-length trimmed)) + "The config file failed to run." + trimmed)))) + (unless (and normal? (zero? status)) + (error 'load-configuration message path-for-errors)) + (if (or (eof-object? text) (zero? (string-length text))) + '() + (nul-strings text)))))) + (lambda () + (handle-exceptions _ #f (close-input-port in)) + (handle-exceptions _ #f (close-input-port err)) + (when (file-exists? tmp-path) (delete-file* tmp-path))))))))) + + (define (evaluate-file path) + (evaluate-text (read-text path) path)) + (define (digits? text) - (and (not (zero? (string-length text))) - (let loop ((characters (string->list text))) - (or (null? characters) - (and (char-numeric? (car characters)) (loop (cdr characters))))))) + (and (decimal-string->number text) #t)) - (define (normalize-loaded-directory path) (or (canonical-directory path) path)) + ;; Missing paths resolve to #f. The loader drops them. This matches the + ;; launcher, which ignores missing paths. Stale entries stay out of the + ;; effective set. add-directory! already rejects missing paths. + (define (normalize-loaded-directory path) + (and (string? path) (canonical-directory path))) (define (partition-arguments arguments) - (let loop ((remaining arguments) (directories '()) (ports '()) (preserved '())) + (let loop ((remaining arguments) (directories '()) (ports '()) (preserved-reversed '())) (cond ((null? remaining) - (values directories (sort ports <) preserved)) + (values directories (sort ports <) (reverse preserved-reversed))) ((string=? (car remaining) "--rwx") (if (null? (cdr remaining)) - (error 'load-configuration "missing value for --rwx") - (loop (cddr remaining) - (append-unique directories (normalize-loaded-directory (cadr remaining))) - ports - preserved))) + (error 'load-configuration "Missing value for --rwx.") + (let ((directory (normalize-loaded-directory (cadr remaining)))) + (loop (cddr remaining) + (if directory + (append-unique directories directory) + directories) + ports + preserved-reversed)))) ((string=? (car remaining) "--connect-tcp") (if (null? (cdr remaining)) - (error 'load-configuration "missing value for --connect-tcp") - (let ((port (and (digits? (cadr remaining)) (string->number (cadr remaining))))) + (error 'load-configuration "Missing value for --connect-tcp.") + (let ((port (decimal-string->number (cadr remaining)))) (if (not (port-valid? port)) - (error 'load-configuration "invalid --connect-tcp port" (cadr remaining)) + (error 'load-configuration "Invalid --connect-tcp port." (cadr remaining)) (loop (cddr remaining) directories (append-unique ports port) - preserved))))) - (else (loop (cdr remaining) directories ports (append preserved (list (car remaining)))))))) + preserved-reversed))))) + ;; Preserved arguments cons then reverse. Appending per element costs more. + (else (loop (cdr remaining) directories ports + (cons (car remaining) preserved-reversed)))))) (define (global-init-path) - (or (get-environment-variable "PISOL_INIT_CONFIG") - (let ((xdg (get-environment-variable "XDG_CONFIG_HOME")) - (home (get-environment-variable "HOME"))) + (or (nonempty-env "PISOL_INIT_CONFIG") + (let ((xdg (nonempty-env "XDG_CONFIG_HOME")) + (home (nonempty-env "HOME"))) (and (or xdg home) (string-append (or xdg (string-append home "/.config")) "/pisol/init"))))) + ;; Read the local file once. The text feeds the style check and bash. + (define (try-read-text path) + (handle-exceptions exn + (if (file-exists? path) (abort exn) #f) + (and (file-exists? path) (read-text path)))) + (define (load-configuration project-path config-path) (let ((project (or (canonical-directory project-path) - (error 'load-configuration "project is not a directory" project-path)))) + (error 'load-configuration "The project is not a directory." project-path)))) (let* ((global-path (global-init-path)) (baseline-args (if (and global-path (file-exists? global-path)) - (evaluate-config global-path) + (evaluate-file global-path) '())) - (local-exists? (file-exists? config-path)) + (local-text (try-read-text config-path)) + (local-exists? (and local-text #t)) (source-style (if local-exists? - (if (canonical-source? (read-text config-path)) 'canonical 'custom) + (if (canonical-source? local-text) 'canonical 'custom) 'absent)) - (local-args (if local-exists? (evaluate-config config-path) '()))) + (local-args (if local-exists? (evaluate-text local-text config-path) '()))) (receive (base-dirs base-ports base-preserved) (partition-arguments baseline-args) (receive (local-dirs local-ports local-preserved) (partition-arguments local-args) (let ((config (make-configuration project config-path baseline-args @@ -257,21 +362,31 @@ (configuration-local-outbound-ports config)) (display ")\n")))) + ;; Write through the mkstemp descriptor. Do not close and reopen the path. + ;; Close and reopen leaves a window where someone can swap the path. (define (save-configuration! config) (let* ((path (configuration-config-path config)) - (template (make-pathname (pathname-directory path) "pisol.save.XXXXXX")) - (temporary - (receive (fd temp-path) (file-mkstemp template) - (file-close fd) - temp-path))) - (handle-exceptions exn - (begin (when (file-exists? temporary) (delete-file* temporary)) (abort exn)) - (with-output-to-file temporary (lambda () (display (config->shell config)))) - (set-file-permissions! temporary #o600) - ;; Clobber via rename-file's own flag rather than delete-then-rename, - ;; so the replacement is atomic and a kill between the two steps - ;; cannot leave the user with neither file. - (rename-file temporary path #t) - (configuration-source-style-set! config 'canonical) - (configuration-dirty?-set! config #f) - #t)))) + (directory (or (pathname-directory path) ".")) + (template (make-pathname directory "pisol.save.XXXXXX"))) + (receive (fd temporary) (file-mkstemp template) + (handle-exceptions exn + (begin (handle-exceptions _ #f (file-close fd)) + (when (file-exists? temporary) (delete-file* temporary)) + (abort exn)) + (let ((out (open-output-file* fd))) + (handle-exceptions exn + (begin (handle-exceptions _ #f (close-output-port out)) + (handle-exceptions _ #f (file-close fd)) + (when (file-exists? temporary) (delete-file* temporary)) + (abort exn)) + (display (config->shell config) out) + (flush-output out) + ;; Closing the port releases the descriptor. + (close-output-port out))) + (set-file-permissions! temporary #o600) + ;; Clobber with rename-file's own flag, not delete then rename. + ;; The swap is atomic. A kill in the middle cannot leave neither file. + (rename-file temporary path #t) + (configuration-source-style-set! config 'canonical) + (configuration-dirty?-set! config #f) + #t))))) blob - f0b1333a5958b6a74337dbd610c36ebb1b186c92 blob + 85376a08b975c9340dd82133181797eca2d28103 --- src/pisol/tui.scm +++ src/pisol/tui.scm @@ -3,70 +3,150 @@ (chicken io) (chicken port) (chicken process) (chicken process-context) pisol.core) (define esc (string (integer->char 27))) - (define color? (not (get-environment-variable "NO_COLOR"))) - (define (ansi code text) (if color? (string-append esc "[" code "m" text esc "[0m") text)) + (define (color-enabled?) (not (get-environment-variable "NO_COLOR"))) + (define (ansi code text) (if (color-enabled?) (string-append esc "[" code "m" text esc "[0m") text)) (define (cyan text) (ansi "38;2;155;246;255" text)) (define (yellow text) (ansi "38;2;253;255;182" text)) (define (muted text) (ansi "38;2;108;117;125" text)) (define (intense text) (ansi "1;38;2;248;249;250" text)) - (define (clear-screen) (display esc) (display "[2J") (display esc) (display "[H")) + (define (clear-screen) + (display esc) (display "[2J") (display esc) (display "[H") + (flush-output)) + ;; Keep newlines and tabs. Replace other control characters. A hostile + ;; path or status line cannot then inject terminal output. + (define (sanitize-display text) + (list->string + (map (lambda (character) + (cond ((or (char=? character #\newline) (char=? character #\tab)) character) + ((and (char>=? character #\space) + (not (char=? character #\x7f))) + character) + (else #\?))) + (string->list text)))) + (define (glued-argument-start? character) + (or (and (char>=? character #\0) (char<=? character #\9)) + (char=? character #\/) (char=? character #\.) + (char=? character #\~))) + (define (known-command? text) + (or (string=? text "") (string=? text "?") (string=? text "h") + (string=? text "a") (string=? text "r") (string=? text "p") + (string=? text "d") (string=? text "c") (string=? text "x"))) (define (split-command text) - (let ((text (trim text))) (let loop ((at 0)) - (cond ((= at (string-length text)) (values text "")) - ((and (= at 1) (> (string-length text) 1) (not (char-whitespace? (string-ref text 1)))) (values (substring text 0 1) (substring text 1 (string-length text)))) - ((char-whitespace? (string-ref text at)) (values (substring text 0 at) (trim (substring text at (string-length text))))) - (else (loop (+ at 1))))))) + (let ((text (trim text))) + (let loop ((at 0)) + (cond ((= at (string-length text)) (values text "")) + ((char-whitespace? (string-ref text at)) + (values (substring text 0 at) + (trim (substring text at (string-length text))))) + (else (loop (+ at 1))))))) + (define (split-command-glued text command argument) + ;; Accept p443-style input only. Split a single-letter command from an + ;; argument that starts with a digit, slash, dot or tilde. Keep words + ;; like "add" whole, so they report as unknown instead of running "a". + (if (and (= (string-length command) 1) + (> (string-length argument) 0) + (not (known-command? argument)) + (member (substring command 0 1) '("a" "r" "p" "d" "c" "x" "?")) + (glued-argument-start? (string-ref argument 0))) + (values command argument) + (values text ""))) + (define (parse-command text) + (let ((text (trim text))) + (call-with-values (lambda () (split-command text)) + (lambda (command argument) + (if (and (string=? argument "") + (> (string-length command) 1) + (not (string-contains-whitespace? text))) + (split-command-glued + text + (substring command 0 1) + (substring command 1 (string-length command))) + (values command argument)))))) + (define (string-contains-whitespace? text) + (let loop ((at 0)) + (cond ((= at (string-length text)) #f) + ((char-whitespace? (string-ref text at)) #t) + (else (loop (+ at 1)))))) (define (read-input prompt) (display prompt) (flush-output) (let ((line (read-line))) (and (not (eof-object? line)) line))) (define (terminal-input?) (terminal-port? (current-input-port))) - (define (temporary-path) - ;; file-mkstemp rather than a counter derived from the current second: - ;; two tui runs started in the same second could otherwise collide on - ;; the same path and race to read each other's captured input. - (let ((template (string-append (or (get-environment-variable "TMPDIR") "/tmp") "/pisol-path.XXXXXX"))) - (receive (fd path) (file-mkstemp template) - (file-close fd) - path))) + (define (temporary-capture-path) + ;; Use a private 0700 directory, not a bare mkstemp file. Bash writes + ;; inside it. A run in the same second cannot collide. Another user + ;; cannot swap the capture path. + (let* ((directory (create-temporary-directory)) + (path (string-append directory "/input"))) + (values directory path))) (define (read-directory-path prompt initial) (if (not (terminal-input?)) (read-input prompt) - (let ((output (temporary-path))) - (dynamic-wind (lambda () #f) - (lambda () (let ((status (system (string-append "bash -c " (shell-quote "IFS= read -e -r -i \"$3\" -p \"$1\" path || exit $?; printf '%s' \"$path\" > \"$2\"") " bash " (shell-quote prompt) " " (shell-quote output) " " (shell-quote initial))))) - (and (zero? status) (file-exists? output) (read-text output)))) - (lambda () (when (file-exists? output) (delete-file output))))))) + (call-with-values temporary-capture-path + (lambda (directory output) + (dynamic-wind (lambda () #f) + (lambda () (let ((status (system (string-append "bash -c " (shell-quote "IFS= read -e -r -i \"$3\" -p \"$1\" path || exit $?; printf '%s' \"$path\" > \"$2\"") " bash " (shell-quote prompt) " " (shell-quote output) " " (shell-quote initial))))) + (and (zero? status) + (file-exists? output) + (let ((text (handle-exceptions _ #f (read-text output)))) + (and (string? text) text))))) + (lambda () + (when (file-exists? output) + (handle-exceptions _ #f (delete-file output))) + (handle-exceptions _ #f (delete-directory directory)))))))) (define (choose-directory) (let* ((home (get-environment-variable "HOME")) (default (if (and home (directory? home)) (if (string=? home "/") home (string-append home "/")) ""))) - (let ((entry (read-directory-path "" default))) (and entry (let ((path (trim entry))) (if (string=? path "") default path)))))) + (let ((entry (read-directory-path "" default))) + (and (string? entry) + (let ((path (trim entry))) + (if (string=? path "") default path)))))) (define (integer-text text) - (and (> (string-length text) 0) - (let loop ((characters (string->list text))) - (or (null? characters) (and (char-numeric? (car characters)) (loop (cdr characters))))) - (string->number text))) + (and (string? text) (decimal-string->number text))) + (define (safe-read-text path) + (handle-exceptions _ #f (read-text path))) (define (show-config-files config) (clear-screen) (display (intense "pisol configuration files")) (newline) (newline) (display (cyan "Global init")) (newline) - (let ((global (global-init-path))) (if (not global) (begin (display (yellow "not configured")) (newline)) - (begin (display (muted global)) (newline) (if (file-exists? global) (display (read-text global)) (display (yellow "absent"))) (newline)))) - (newline) (display (cyan "Local config")) (newline) (let ((local (configuration-config-path config))) (display (muted local)) (newline) (if (file-exists? local) (display (read-text local)) (display (yellow "absent"))) (newline)) + (let ((global (global-init-path))) + (if (not global) + (begin (display (yellow "not configured")) (newline)) + (begin (display (muted (sanitize-display global))) (newline) + (let ((text (and (file-exists? global) (safe-read-text global)))) + (if text + (display (sanitize-display text)) + (display (yellow "absent")))) + (newline)))) + (newline) (display (cyan "Local config")) (newline) + (let ((local (configuration-config-path config))) + (display (muted (sanitize-display local))) (newline) + (let ((text (and (file-exists? local) (safe-read-text local)))) + (if text + (display (sanitize-display text)) + (display (yellow "absent")))) + (newline)) (read-input "Press enter to return. ")) (define (render config status) - (clear-screen) (display (intense "pisol")) (newline) (display (muted "config: ")) (display (configuration-config-path config)) + (clear-screen) (display (intense "pisol")) (newline) (display (muted "config: ")) (display (sanitize-display (configuration-config-path config))) (when (eq? (configuration-source-style config) 'custom) (display (yellow " custom shell"))) (newline) (newline) (display (cyan "Writable directories")) (newline) (let ((dirs (configuration-local-writable-directories config))) (if (null? dirs) (begin (display (muted " none")) (newline)) - (let loop ((items dirs) (index 1)) (unless (null? items) (format #t "~a ~a~%" index (car items)) (loop (cdr items) (+ index 1)))))) + (let loop ((items dirs) (index 1)) (unless (null? items) (format #t "~a ~a~%" index (sanitize-display (car items))) (loop (cdr items) (+ index 1)))))) (newline) (display (cyan "Outbound TCP ports")) (newline) (let ((ports (configuration-local-outbound-ports config))) (if (null? ports) (begin (display (muted " none")) (newline)) (begin (display " ") (for-each (lambda (port) (format #t "~a " port)) ports) (newline)))) - (newline) (display "a add dir r remove dir p add port d remove port") (newline) (display "c config x save and exit") (newline) - (unless (string=? status "") (display (yellow status)) (newline))) - (define (show-help) (clear-screen) (display (intense "pisol help")) (newline) (newline) (display "The path starts at your home directory. Press Tab to complete it.") (newline) (display "Press Tab twice to list matching paths.") (newline) (display "The baseline writable tree cannot be added again. TCP is denied unless listed.") (newline) (newline) (display "Custom .isolate files are trusted shell code. Saving replaces them with") (newline) (display "a static list of sandbox grants.") (newline) (display "c shows the raw global and local configuration files.") (newline) (read-input "Press enter to return. ")) + (newline) (display "a add dir r remove dir p add port d remove port") (newline) (display "c config x save and exit ? help") (newline) + (unless (string=? status "") (display (yellow (sanitize-display status))) (newline)) + (flush-output)) + (define (show-help) (clear-screen) (display (intense "pisol help")) (newline) (newline) (display "Start from your home directory. Press Tab to complete a path.") (newline) (display "Press Tab twice to list matching paths.") (newline) (display "You cannot add the baseline tree again. The sandbox blocks TCP") (newline) (display "unless you list a port.") (newline) (newline) (display "Custom .isolate files are shell code you trust. Saving replaces them") (newline) (display "with a static list of grants.") (newline) (display "Use c to show the global and local files.") (newline) (display "Ending input also leaves without saving.") (newline) (read-input "Press enter to return. ")) + (define (exn-message exn) + (let ((message (handle-exceptions _ #f (get-condition-property exn 'exn 'message)))) + (if (string? message) + message + (with-output-to-string (lambda () (display exn)))))) (define (run-tui config) (let loop ((status "")) (render config status) (let ((input (read-input "> "))) - (if (not input) #t (call-with-values (lambda () (split-command input)) + ;; End of input exits without saving. Piped runs never write. + (if (not input) #t (call-with-values (lambda () (parse-command input)) (lambda (command argument) (cond - ((string=? command "a") (let ((path (choose-directory))) (cond ((not path) #t) ((string=? (trim path) "") (loop "directory path is required")) ((add-directory! config (trim path)) (loop (string-append (trim path) " added"))) (else (loop "directory is missing, duplicated, or already writable"))))) - ((string=? command "r") (let ((dirs (configuration-local-writable-directories config))) (if (null? dirs) (loop "no writable directory to remove") (let ((index (or (and (> (string-length argument) 0) (integer-text argument)) (let ((text (read-input "Directory number: "))) (and text (integer-text (trim text))))))) (if (and index (<= 1 index (length dirs))) (begin (remove-directory! config (list-ref dirs (- index 1))) (loop "directory removed")) (loop "enter a number from the writable directory list")))))) - ((string=? command "p") (let ((port (integer-text argument))) (if (and port (add-port! config port)) (loop (format "added outbound TCP port ~a" port)) (loop "port must be unique and between 1 and 65535")))) - ((string=? command "d") (let ((ports (configuration-local-outbound-ports config))) (if (null? ports) (loop "no outbound TCP port to remove") (let ((port (or (and (> (string-length argument) 0) (integer-text argument)) (let ((text (read-input "Port: "))) (and text (integer-text (trim text))))))) (if (and port (remove-port! config port)) (loop (format "removed outbound TCP port ~a" port)) (loop "configured port not found")))))) - ((string=? command "?") (show-help) (loop "")) ((string=? command "c") (show-config-files config) (loop "")) - ((string=? command "x") (if (not (configuration-dirty? config)) #t (handle-exceptions exn (loop (format "save failed: ~a" exn)) (save-configuration! config) #t))) - ((string=? command "") (loop status)) (else (loop "unknown command; enter ? for help")))))))))) + ((string=? command "a") (let ((path (choose-directory))) (cond ((not path) (loop "Cancelled. Nothing changed.")) ((string=? (trim path) "") (loop "Enter a directory path.")) ((add-directory! config (trim path)) (loop (string-append "Added " (sanitize-display (trim path)) "."))) (else (loop "That directory is missing, duplicated or already writable."))))) + ((string=? command "r") (let ((dirs (configuration-local-writable-directories config))) (if (null? dirs) (loop "There is no writable directory to remove.") (let ((index (if (> (string-length argument) 0) (integer-text argument) (let ((text (read-input "Directory number: "))) (and (string? text) (integer-text (trim text))))))) (if (and index (<= 1 index (length dirs))) (begin (remove-directory! config (list-ref dirs (- index 1))) (loop "Removed the directory.")) (loop "Enter a number from the list.")))))) + ((string=? command "p") (let ((port (integer-text argument))) (if (and port (add-port! config port)) (loop (format "Added port ~a." port)) (loop "Enter a unique port from 1 to 65535.")))) + ((string=? command "d") (let ((ports (configuration-local-outbound-ports config))) (if (null? ports) (loop "There is no port to remove.") (let ((port (if (> (string-length argument) 0) (integer-text argument) (let ((text (read-input "Port: "))) (and (string? text) (integer-text (trim text))))))) (cond ((and port (remove-port! config port)) (loop (format "Removed port ~a." port))) ((and port (member port (configuration-outbound-ports config))) (loop "That port comes from the global file. Edit that file to remove it.")) (else (loop "That port is not in the local file."))))))) + ((or (string=? command "?") (string=? command "h")) (show-help) (loop "")) ((string=? command "c") (show-config-files config) (loop "")) + ((string=? command "x") (if (not (configuration-dirty? config)) #t (handle-exceptions exn (loop (string-append "Save failed: " (exn-message exn))) (save-configuration! config) #t))) + ((string=? command "") (loop status)) (else (loop "Unknown command. Enter ? for help.")))))))))) blob - 67de22edd1873179fbe15d14cfea8cb8167ed330 blob + 1041dc4b3020b1f64d2f306a91c81a44bb1437ef --- test/test.scm +++ test/test.scm @@ -1,6 +1,7 @@ (include "src/pisol/core.scm") (import scheme (chicken base) (chicken file) (chicken file posix) (chicken io) - (chicken port) (chicken format) (chicken process-context) (chicken time) + (chicken port) (chicken format) (chicken process-context) + (chicken process-context posix) pisol.core) (set-environment-variable! "PISOL_INIT_CONFIG" "/tmp/pisol-no-global-init") @@ -23,7 +24,10 @@ (call-with-output-file path (lambda (port) (display text port)))) (define (read-text path) - (call-with-input-file path (lambda (port) (read-string #f port)))) + (call-with-input-file path + (lambda (port) + (let ((text (read-string #f port))) + (if (eof-object? text) "" text))))) (define (string-contains? haystack needle) (let ((n (string-length needle)) (m (string-length haystack))) @@ -32,13 +36,10 @@ ((string=? (substring haystack i (+ i n)) needle) #t) (else (loop (+ i 1))))))) -(define temporary-counter 0) +;; Use unique 0700 directories. Counter names collide across runs and reuse +;; stale directories. (define (temporary-root) - (set! temporary-counter (+ temporary-counter 1)) - (let ((path (string-append "/tmp/pisol-test-" - (number->string (current-seconds)) "." - (number->string temporary-counter)))) - (mkdir-p path) path)) + (create-temporary-directory)) (define test-home (temporary-root)) (set-environment-variable! "HOME" test-home) @@ -49,6 +50,8 @@ (check (not (port-valid? 0)) "zero port is invalid") (check (not (port-valid? 65536)) "port above maximum is invalid") (check (not (port-valid? "443")) "non-integer port is invalid") + (check (not (decimal-string->number "443 ")) "trailing space is not a port") + (check (not (decimal-string->number "")) "empty string is not a port") (let ((config (make-empty-configuration "/project" "/project/.isolate"))) (check (add-port! config 443) "add a valid port") (check-equal (configuration-outbound-ports config) '(443) "port is exposed") @@ -78,6 +81,20 @@ (check (remove-directory! config outside) "remove existing directory") (check (not (remove-directory! config outside)) "missing directory removal rejected")))) +(define (symlink-tests) + (let* ((root (temporary-root)) + (project (string-append root "/project")) + (outside (string-append root "/outside")) + (link (string-append root "/link"))) + (mkdir-p project) + (mkdir-p outside) + (create-symbolic-link outside link) + (let ((config (make-empty-configuration project (string-append project "/.isolate")))) + (check (add-directory! config link) "symlinked directory resolves") + (check-equal (configuration-writable-directories config) (list outside) + "symlink stores its target") + (check (not (add-directory! config outside)) "resolved duplicate rejected")))) + (define (quote-tests) (check-equal (shell-quote "plain") "'plain'" "simple shell quote") (check-equal (shell-quote "a b") "'a b'" "space shell quote") @@ -129,66 +146,87 @@ "invalid recognized port rejects config") (write-text path "args+=(--rwx)\n") (check (handle-exceptions _ #t (load-configuration project path) #f) - "missing recognized operand rejects config"))) + "missing recognized operand rejects config") + (write-text path + (string-append "args+=(\n" + " --rwx '" root "/gone'\n" + " --connect-tcp 443\n" + ")\n")) + (let ((pruned (load-configuration project path))) + (check-equal (configuration-writable-directories pruned) '() + "missing loaded directory is dropped") + (check-equal (configuration-outbound-ports pruned) '(443) + "ports survive missing directory")))) (define (baseline-tests) - (let* ((root (temporary-root)) - (home (string-append root "/home")) - (global (string-append home "/.config/pisol/init")) - (project (string-append root "/project")) - (outside (string-append root "/outside")) - (path (string-append project "/.isolate"))) - (mkdir-p home) - (set-environment-variable! "HOME" home) - (set-environment-variable! "PISOL_INIT_CONFIG" global) - (mkdir-p (string-append home "/.config")) - (mkdir-p (string-append home "/.config/pisol")) - (mkdir-p project) - (mkdir-p outside) - (write-text global - (string-append "args+=(\n" - " --ro '/opt/global'\n" - " --rwx '" root "/outside'\n" - " --connect-tcp 80\n" - ")\n")) - (write-text path - (string-append "args+=(\n" - " --connect-tcp 443\n" - ")\n")) - (let ((config (load-configuration project path))) - (check-equal (configuration-source-style config) 'canonical - "canonical local source detected with baseline") - (check-equal (configuration-preserved-arguments config) '("--ro" "/opt/global") - "global preserved arguments merged") - (check-equal (configuration-writable-directories config) (list outside) - "global writable directory merged") - (check-equal (configuration-outbound-ports config) '(80 443) - "global and local ports merged") - (check-equal (configuration-local-outbound-ports config) '(443) - "local port stored separately") - (check (not (configuration-dirty? config)) "loaded baseline config is clean") - (check (not (add-directory! config outside)) "duplicate global directory rejected") - (check (not (remove-directory! config outside)) "global directory cannot be removed here") - (check (add-port! config 8080) "local port added on top of baseline") - (save-configuration! config) - (let ((saved (read-text path))) - (check (not (string-contains? saved "/opt/global")) - "save does not duplicate global arguments") - (check (string-contains? saved "--connect-tcp 443") - "local port survives save") - (check (string-contains? saved "--connect-tcp 8080") - "added local port saved"))) - (let ((empty-local (load-configuration project (string-append project "/missing.isolate")))) - (check-equal (configuration-source-style empty-local) 'absent - "missing local config with baseline is absent") - (check-equal (configuration-writable-directories empty-local) (list outside) - "baseline grants available without local file") - (check (not (configuration-dirty? empty-local)) "baseline-only config is clean")) - (set-environment-variable! "HOME" test-home) - (set-environment-variable! "PISOL_INIT_CONFIG" "/tmp/pisol-no-global-init"))) + (let ((saved-home (get-environment-variable "HOME")) + (saved-init (get-environment-variable "PISOL_INIT_CONFIG"))) + (dynamic-wind + void + (lambda () + (let* ((root (temporary-root)) + (home (string-append root "/home")) + (global (string-append home "/.config/pisol/init")) + (project (string-append root "/project")) + (outside (string-append root "/outside")) + (path (string-append project "/.isolate"))) + (mkdir-p home) + (set-environment-variable! "HOME" home) + (set-environment-variable! "PISOL_INIT_CONFIG" global) + (mkdir-p (string-append home "/.config")) + (mkdir-p (string-append home "/.config/pisol")) + (mkdir-p project) + (mkdir-p outside) + (write-text global + (string-append "args+=(\n" + " --ro '/opt/global'\n" + " --rwx '" root "/outside'\n" + " --connect-tcp 80\n" + ")\n")) + (write-text path + (string-append "args+=(\n" + " --connect-tcp 443\n" + ")\n")) + (let ((config (load-configuration project path))) + (check-equal (configuration-source-style config) 'canonical + "canonical local source detected with baseline") + (check-equal (configuration-preserved-arguments config) '("--ro" "/opt/global") + "global preserved arguments merged") + (check-equal (configuration-writable-directories config) (list outside) + "global writable directory merged") + (check-equal (configuration-outbound-ports config) '(80 443) + "global and local ports merged") + (check-equal (configuration-local-outbound-ports config) '(443) + "local port stored separately") + (check (not (configuration-dirty? config)) "loaded baseline config is clean") + (check (not (add-directory! config outside)) "duplicate global directory rejected") + (check (not (remove-directory! config outside)) "global directory cannot be removed here") + (check (add-port! config 8080) "local port added on top of baseline") + (save-configuration! config) + (let ((saved (read-text path))) + (check (not (string-contains? saved "/opt/global")) + "save does not duplicate global arguments") + (check (string-contains? saved "--connect-tcp 443") + "local port survives save") + (check (string-contains? saved "--connect-tcp 8080") + "added local port saved"))) + (let ((empty-local (load-configuration project (string-append project "/missing.isolate")))) + (check-equal (configuration-source-style empty-local) 'absent + "missing local config with baseline is absent") + (check-equal (configuration-writable-directories empty-local) (list outside) + "baseline grants available without local file") + (check (not (configuration-dirty? empty-local)) "baseline-only config is clean")))) + (lambda () + (if saved-home + (set-environment-variable! "HOME" saved-home) + (unset-environment-variable! "HOME")) + (if saved-init + (set-environment-variable! "PISOL_INIT_CONFIG" saved-init) + (unset-environment-variable! "PISOL_INIT_CONFIG")))))) (port-tests) (directory-tests) +(symlink-tests) (quote-tests) (configuration-tests) (baseline-tests)