commit c78f50be073c1324df8ced7730ea3538e92580f4 from: mtmn date: Thu Aug 27 21:14:34 2026 UTC init commit - /dev/null commit + c78f50be073c1324df8ced7730ea3538e92580f4 blob - /dev/null blob + 56149432a994999960a06ea4683bf3a81755118c (mode 644) --- /dev/null +++ .gitignore @@ -0,0 +1,3 @@ +/build/ +/src/pisol/*.so +/.ninja_log blob - /dev/null blob + 9d3d55da1c82b606c81201f981976630752bad97 (mode 644) --- /dev/null +++ LICENSE @@ -0,0 +1,22 @@ +MIT License + +Copyright (c) 2026 mtmn + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. + blob - /dev/null blob + a49a799b818e2bc6cc27a688512f776ab95f4faa (mode 644) --- /dev/null +++ Makefile @@ -0,0 +1,62 @@ +LIBDIR = src +SCHEME ?= scheme + +.PHONY: build tui test copy-config clean run fmt install uninstall help + +default: help + +build: build/runtime/pisol.so + +build/runtime/pisol.so: bin/pisol.ss src/pisol/core.sls src/pisol/tui.sls tools/build.ss + @mkdir -p build/runtime/lib/pisol + $(SCHEME) --libdirs $(LIBDIR) --compile-imported-libraries --program tools/build.ss + cp src/pisol/core.so src/pisol/tui.so build/runtime/lib/pisol/ + +tui: build + $(SCHEME) --libdirs $(LIBDIR) --program bin/pisol.ss + +test: build + shellcheck bin/pisol test/integration.sh tools/fmt.sh + $(SCHEME) --libdirs $(LIBDIR) --program test/test.ss + sh test/integration.sh + +copy-config: + @config_home="$${XDG_CONFIG_HOME:-$$HOME/.config}"; \ + target="$$config_home/pisol/init"; \ + s=; if [ -e "$$config_home" ] && [ ! -w "$$config_home" ]; then s=sudo; fi; \ + if [ -f "$$target" ]; then \ + printf 'pisol: %s already exists\n' "$$target" >&2; \ + exit 1; \ + fi; \ + $$s install -d "$$config_home/pisol" && \ + $$s install -m 644 config/pisol/init "$$target" + +clean: + rm -rf build src/pisol/core.so src/pisol/tui.so + +run: install + bash /usr/local/bin/pisol + +fmt: + sh tools/fmt.sh src/pisol/core.sls src/pisol/tui.sls bin/pisol.ss test/test.ss tools/build.ss + +install: + ninja install + +uninstall: + ninja uninstall + +help: + @printf '%s\n' \ + 'make build Compile the Chez Scheme program' \ + 'make tui Run the configuration TUI' \ + 'make test Run specification, static, Chez, shell, and TUI tests' \ + 'make run Install and run pisol' \ + 'make fmt Format Scheme sources with emacs scheme-mode' \ + 'make copy-config Copy the default global init to ~/.config/pisol/init' \ + 'make clean Remove generated artifacts' \ + 'make install Install pisol and its manual' \ + 'make uninstall Remove installed pisol files' \ + 'make help Show this help message' \ + '' \ + 'Variables: SCHEME=scheme' blob - /dev/null blob + 27240973130df2f0ca7d57de805a4629cab6811f (mode 644) --- /dev/null +++ README.md @@ -0,0 +1,112 @@ +# pisol + +Working-directory Landrun isolation and configuration, with a terminal interface +written in Chez Scheme. + +`pisol` combines command isolation with an editor for the local trusted +`.isolate` shell fragment. Outbound TCP is denied by default. The editor manages +extra writable/executable directories and the destination TCP ports commands +may connect to. + +## Run + +You need Bash, [Landrun](https://github.com/Zouuup/landrun), Chez Scheme 10.4 or +newer, and Ninja. Install `fzf` for fuzzy directory selection. Without it, the +editor uses direct path entry. Install `emacs` to run `ninja fmt`. + +```sh +ninja tui +ninja test +``` + +After installation, open the editor in the working directory: + +```sh +pisol +``` + +Run a command in that directory sandbox: + +```sh +pisol -- your-command --with arguments +``` + +The command receives the caller environment, `PROMPT_ENV_INDICATOR=isolated`, +and `ISOLATE_ENV` set to the canonical working directory. Calling `pisol -- ...` +inside an existing pisol sandbox prints a warning and directly executes the +command rather than creating a nested Landlock domain. + +## TUI commands + +```text +a fuzzy-find or enter a writable directory path +r choose and remove a writable directory +p PORT allow outbound TCP connections to a destination port +d enter and remove an outbound TCP port +c show global and local configuration file contents +s save +sx save and exit immediately (xs also works) +? help +x exit (discards any unsaved changes) +``` + +After selecting `a`, enter a base path such as `/home/miro`, or press Enter to +open the picker in your home directory. `fzf` then lists that path and its +immediate child directories only. Press Enter to drill down into a directory, +Alt+Enter or Ctrl-S to select it, or Escape to use the typed path directly. +The baseline writable tree cannot be added redundantly. + +Set `NO_COLOR=1` to disable colour. `COLUMNS` and `LINES` are respected by the +terminal environment. Set `ISOLATE_EXTRA_CONFIG` to use a config path other +than `CURRENT_DIRECTORY/.isolate`. + +## Configuration and trust + +`.isolate` is sourced as trusted Bash by the launcher. A generated file looks +like this: + +```bash +args+=( + --rwx '/home/example/shared work' + --connect-tcp 443 +) +``` + +A global init file at `~/.config/pisol/init` is sourced before the local +`.isolate` when it exists. Put shared grants there; the project-specific file +builds on top of it. Override the path with `PISOL_INIT_CONFIG`. + +A permissive example init based on the legacy `isolate` script is included at +`config/pisol/init`. Copy it to `~/.config/pisol/init` and edit to taste; +remove `--unrestricted-network` to keep outbound TCP denied by default. + +The TUI also evaluates existing custom `.isolate` logic. It extracts the +resulting `--rwx` and `--connect-tcp` entries and preserves other resulting +Landrun arguments. Saving custom logic requires confirmation because the source +is replaced by a canonical argument array; comments and dynamic logic are not +retained. Default grants from the global init are shown but not edited in the +TUI; add or remove project-specific entries instead. + +The minimal default policy grants the working tree read/write/execute access, +temporary storage write access, read access to system configuration/data, and +read/execute access to standard runtime and absolute `PATH` directories. It +also grants the standard null, zero, random, and controlling-terminal devices, +but does not grant unrestricted networking. A Wayland socket is added when +`WAYLAND_DISPLAY` and `XDG_RUNTIME_DIR` are set. + +## Build and install + +```sh +ninja build +ninja test +ninja fmt +ninja install +ninja copy-config +``` + +`ninja fmt` reindents the Scheme sources in place with `emacs` scheme-mode. Run +it after editing Scheme files; it is a no-op on already-formatted files. + +`ninja install` defaults to `/usr/local` and asks for `sudo` only when needed. +Set `PREFIX`, `DESTDIR`, `BINDIR`, `LIBEXECDIR`, `MANDIR`, or `SCHEME` to +override the defaults. See `pisol(1)` after installation. blob - /dev/null blob + 0966c7b012fa721f124c9d3989f4a31de57a5038 (mode 755) --- /dev/null +++ bin/pisol @@ -0,0 +1,126 @@ +#!/usr/bin/env bash +set -euo pipefail + +pisol_usage() { + cat <<'EOF' +Usage: pisol + pisol -- COMMAND [ARG...] + +With no arguments, edit the local .isolate configuration. +With --, execute COMMAND in the current directory Landrun sandbox. +EOF +} + +pisol_bin_dir=$(CDPATH='' cd -- "$(dirname -- "$0")" && pwd) +pisol_runtime_dir=${PISOL_RUNTIME_DIR:-$pisol_bin_dir/../libexec/pisol} + +case ${1:-} in +-h|--help) + pisol_usage + exit 0 + ;; +--version) + printf '%s\n' 'pisol 0.1.0' + exit 0 + ;; +"") + pisol_project=$(pwd -P) + pisol_config=${ISOLATE_EXTRA_CONFIG:-$pisol_project/.isolate} + exec "${SCHEME:-scheme}" \ + --libdirs "$pisol_runtime_dir/lib" \ + --program "$pisol_runtime_dir/pisol.so" \ + --project "$pisol_project" \ + --config "$pisol_config" + ;; +--) + shift + if [[ $# -eq 0 ]]; then + printf '%s\n' 'pisol: missing command after --' >&2 + pisol_usage >&2 + exit 2 + fi + ;; +*) + printf 'pisol: unknown option: %s\n' "$1" >&2 + pisol_usage >&2 + exit 2 + ;; +esac + +if [[ -n ${ISOLATE_ENV:-} ]]; then + printf '%s\n' 'pisol: warning: already isolated; executing command directly' >&2 + exec "$@" +fi + +if ! command -v landrun >/dev/null 2>&1; then + printf '%s\n' 'pisol: landrun is not installed or not on PATH' >&2 + exit 127 +fi + +pisol_project=$(pwd -P) +pisol_config=${ISOLATE_EXTRA_CONFIG:-$pisol_project/.isolate} + +env_args=() +while IFS= read -r name; do + env_args+=(--env "$name") +done < <(compgen -e) + +args=( + --best-effort + --ignore-missing + --unrestricted-scoped + --rw /tmp + --env PROMPT_ENV_INDICATOR=isolated + --env "ISOLATE_ENV=$pisol_project" + --rwx "$pisol_project" +) + +declare -A pisol_seen=() +pisol_add_path() { + local mode=$1 path=$2 key + [[ -e $path ]] || return 0 + key=$mode:$path + [[ -z ${pisol_seen[$key]:-} ]] || return 0 + pisol_seen[$key]=1 + args+=("$mode" "$path") +} + +for path in /bin /sbin /lib /lib64 /usr/bin /usr/sbin /usr/lib /usr/lib64 /nix /run/current-system/sw; do + pisol_add_path --rox "$path" +done +for path in /etc /usr/share; do + pisol_add_path --ro "$path" +done +for path in /dev/null /dev/zero /dev/random /dev/urandom /dev/tty; do + pisol_add_path --rw "$path" +done + +IFS=: read -r -a pisol_path_entries <<<"${PATH:-}" +for path in "${pisol_path_entries[@]}"; do + [[ $path = /* ]] && pisol_add_path --rox "$path" +done + +if [[ ${TMPDIR:-} = /* && ${TMPDIR:-} != /tmp ]]; then + pisol_add_path --rw "$TMPDIR" +fi + +if [[ -n ${WAYLAND_DISPLAY:-} && -n ${XDG_RUNTIME_DIR:-} ]]; then + args+=(--unix "${XDG_RUNTIME_DIR}/${WAYLAND_DISPLAY}") +fi + +pisol_init=${PISOL_INIT_CONFIG:-${XDG_CONFIG_HOME:-$HOME/.config}/pisol/init} +if [[ -f $pisol_init ]]; then + # shellcheck disable=SC1090 + source "$pisol_init" +fi + +if [[ -f $pisol_config ]]; then + # shellcheck disable=SC1090 + source "$pisol_config" +fi + +exec landrun \ + "${env_args[@]}" \ + "${args[@]}" \ + -- \ + "$@" blob - /dev/null blob + 2f97d60ac340181b0b19b09d563daabedaf13fda (mode 644) --- /dev/null +++ bin/pisol.ss @@ -0,0 +1,33 @@ +#!/usr/bin/env scheme --program +(import (chezscheme) + (pisol core) + (pisol tui)) + +(define (usage port) + (display "Usage: pisol\n" port) + (display "Internal TUI options: --project PATH --config PATH\n" port)) + +(define (parse arguments) + (let loop ([remaining arguments] [project #f] [config #f]) + (cond + [(null? remaining) (values project config)] + [(and (pair? (cdr remaining)) (string=? (car remaining) "--project")) + (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))]))) + +(guard (condition + (else + (display "pisol: " (current-error-port)) + (display-condition condition (current-error-port)) + (newline (current-error-port)) + (exit 1))) + (let-values ([(project config) (parse (cdr (command-line)))]) + (let* ([project (or (canonical-directory (or project (current-directory))) + (error 'pisol "project is not a directory" project))] + [config (or config + (getenv "ISOLATE_EXTRA_CONFIG") + (string-append project "/.isolate"))]) + (run-tui (load-configuration project config))))) + blob - /dev/null blob + 4d9c7939c5a158d67ec69b06eb25da179a2c1c45 (mode 644) --- /dev/null +++ build.ninja @@ -0,0 +1,32 @@ +ninja_required_version = 1.5 + +libdir = src + +rule compile + command = mkdir -p build/runtime/lib/pisol && $${SCHEME:-scheme} --libdirs $libdir --compile-imported-libraries --program tools/build.ss && cp src/pisol/core.so src/pisol/tui.so build/runtime/lib/pisol/ + description = compiling pisol + +build build/runtime/pisol.so: compile bin/pisol.ss src/pisol/core.sls src/pisol/tui.sls tools/build.ss + +build build: phony build/runtime/pisol.so +default build + +rule install + command = prefix=$${PREFIX:-/usr/local}; bindir=$${BINDIR:-$$prefix/bin}; libexecdir=$${LIBEXECDIR:-$$prefix/libexec/pisol}; mandir=$${MANDIR:-$$prefix/share/man}; destdir=$${DESTDIR:-}; can_create() { d="$$1"; while [ -n "$$d" ] && [ ! -e "$$d" ]; do d=$$(dirname "$$d"); done; [ -d "$$d" ] && [ -w "$$d" ]; }; s=; if ! can_create "$$destdir$$bindir"; then s=sudo; fi; $$s install -d "$$destdir$$bindir" "$$destdir$$libexecdir/lib/pisol" "$$destdir$$mandir/man1" && $$s install -m 755 bin/pisol "$$destdir$$bindir/pisol" && $$s install -m 755 build/runtime/pisol.so "$$destdir$$libexecdir/pisol.so" && $$s install -m 644 build/runtime/lib/pisol/core.so build/runtime/lib/pisol/tui.so "$$destdir$$libexecdir/lib/pisol/" && $$s install -m 644 doc/pisol.1 "$$destdir$$mandir/man1/pisol.1" + pool = console + description = installing pisol + +build install: install build/runtime/pisol.so + +rule uninstall + command = prefix=$${PREFIX:-/usr/local}; bindir=$${BINDIR:-$$prefix/bin}; libexecdir=$${LIBEXECDIR:-$$prefix/libexec/pisol}; mandir=$${MANDIR:-$$prefix/share/man}; destdir=$${DESTDIR:-}; can_create() { d="$$1"; while [ -n "$$d" ] && [ ! -e "$$d" ]; do d=$$(dirname "$$d"); done; [ -d "$$d" ] && [ -w "$$d" ]; }; s=; if ! can_create "$$destdir$$bindir"; then s=sudo; fi; $$s rm -f "$$destdir$$bindir/pisol" "$$destdir$$libexecdir/pisol.so" "$$destdir$$libexecdir/lib/pisol/core.so" "$$destdir$$libexecdir/lib/pisol/tui.so" "$$destdir$$mandir/man1/pisol.1" + pool = console + description = uninstalling pisol + +build uninstall: uninstall + +rule help + command = printf '%s\n' 'ninja install Install pisol and its manual (escalates to sudo if needed)' 'ninja uninstall Remove installed pisol files' '' 'Variables: PREFIX=/usr/local DESTDIR=' ' BINDIR=PREFIX/bin LIBEXECDIR=PREFIX/libexec/pisol MANDIR=PREFIX/share/man' ' NO_COLOR=1' + pool = console + +build help: help blob - /dev/null blob + 63da1b855da6d8a2b9be5d572dfced0d0cb68ee6 (mode 644) --- /dev/null +++ config/pisol/init @@ -0,0 +1,41 @@ +#!/usr/bin/env bash +# Default global init for pisol. +# Sourced before the project-specific .isolate file. Put shared grants here +# and keep per-project additions in $PWD/.isolate. + +# Remove --unrestricted-network below to deny outbound TCP by default, + +args+=(--unrestricted-network) + +for p in \ + /bin \ + /lib \ + /lib64 \ + /usr/bin \ + /usr/lib \ + /etc \ + /nix \ + "$HOME/bin" \ + "$HOME/.zvm" \ + "$HOME/.cargo" \ + "$HOME/.config" \ + "$HOME/.gitconfig" \ + "$HOME/.local/bin" \ + "$HOME/.cache/zig" \ + "$HOME/.rustup" \ + "$HOME/.nix-profile"; do + args+=(--rox "$p") +done + +for p in \ + "$HOME/.codex" \ + "$HOME/.pi" \ + "$HOME/.config/goose" \ + "$HOME/.cache/opencode" \ + "$HOME/.config/opencode" \ + "$HOME/.local/share/opencode" \ + "$HOME/.local/state/opencode" \ + "$HOME/.local/share/goose" \ + "$HOME/.local/state/goose"; do + args+=(--rwx "$p") +done blob - /dev/null blob + 719bc22fcae4c29d6dcd4d5cc3af89279fa2ae73 (mode 644) --- /dev/null +++ doc/pisol.1 @@ -0,0 +1,135 @@ +.TH PISOL 1 "2026-08-27" "pisol" "User Commands" +.SH NAME +pisol \- configure and run working-directory Landrun isolation +.SH SYNOPSIS +.B pisol +.br +.B pisol -- +.I COMMAND +.RI [ ARG ...] +.SH DESCRIPTION +.B pisol +opens a Chez Scheme terminal editor for the current directory isolation +configuration. With +.BR -- , +it replaces itself with +.BR landrun (1) +and executes the command in a working-directory sandbox. +.PP +The canonical current directory defines the writable tree. The configuration +path is +.I CURRENT_DIRECTORY/.isolate +unless +.B ISOLATE_EXTRA_CONFIG +is set. +.SH ISOLATION POLICY +The working tree is readable, writable, and executable. Temporary storage is +writable. Standard runtime and absolute PATH directories are readable and +executable, while system configuration and shared data are read-only. The +standard null, zero, random, and controlling-terminal devices are writable. +.PP +Outbound TCP is denied by default. Only destination ports configured with +.B --connect-tcp +are granted. Scoped IPC restrictions are relaxed, and the current Wayland +socket is granted when its environment variables are available. +.PP +The caller environment is forwarded. The command additionally receives +.B PROMPT_ENV_INDICATOR=isolated +and +.B ISOLATE_ENV +set to the canonical working directory. If +.B ISOLATE_ENV +is already non-empty, pisol warns and directly executes the command without +starting a nested Landlock domain. +.SH TUI COMMANDS +.TP +.B a +Prompt for a base directory path and add it as an additional +read/write/execute grant. With no input, the picker opens in the user's home +directory. When +.BR fzf (1) +is available, the picker lists only the typed path and its immediate child +directories. Press Enter to drill down into a directory, Alt+Enter or +Ctrl-S to select it, or Escape to use the typed path directly. +.TP +.B r +Prompt for the number of a writable directory and remove it. +.TP +.BI p " PORT" +Allow outbound TCP connections to PORT. Valid ports are 1 through 65535. +.TP +.B d +Prompt for a configured outbound TCP port and remove it. +.TP +.B c +Show the resolved global init file and the local configuration file, including their raw contents. A missing file is labelled absent. +.TP +.B s +Save atomically with mode 0600. The combined commands +.B sx +and +.B xs +save and then exit immediately. +.TP +.BR ? , " x" +Show help or exit. Exit discards any unsaved changes. +.SH CONFIGURATION +.I .isolate +is trusted Bash code sourced by the launcher. It modifies the Bash array +.IR args , +normally with an +.B args+=(...) +fragment. +.PP +If +.I ~/.config/pisol/init +exists, it is sourced before the local +.I .isolate . +Put shared grants in the global init file; per-project configuration builds on +top of it. The path can be overridden with +.BR PISOL_INIT_CONFIG . +.PP +A permissive example global init based on the legacy +.I isolate +script is included in the source tree at +.IR config/pisol/init . +Copy it to +.I ~/.config/pisol/init +and edit to customize. Remove +.B --unrestricted-network +from the copy to deny outbound TCP by default. +.PP +The editor evaluates an existing file, manages resulting +.B --rwx +and +.B --connect-tcp +pairs, and preserves other resulting arguments. Saving custom shell logic +requires confirmation and replaces it with a canonical static array; source +comments and dynamic logic are not preserved. Default grants from the global +init file are shown but not editable in the TUI. +.SH ENVIRONMENT +.TP +.B ISOLATE_EXTRA_CONFIG +Override the local configuration path. +.TP +.B PISOL_INIT_CONFIG +Override the global init path. Defaults to +.IR ~/.config/pisol/init . +.TP +.B ISOLATE_ENV +Marks an existing pisol sandbox and prevents nesting. +.TP +.B NO_COLOR +Disable TUI colour when set to any value. +.TP +.BR HOME , " PATH" , " TMPDIR" +Supply runtime paths and grants. +.TP +.BR WAYLAND_DISPLAY , " XDG_RUNTIME_DIR" +Identify an optional Wayland Unix socket grant. +.SH EXIT STATUS +The TUI returns zero on normal exit and non-zero on load or save errors. In +command mode, pisol propagates the executed command status. Usage errors +return 2 and a missing Landrun executable returns 127. +.SH SEE ALSO +.BR fzf (1) blob - /dev/null blob + 0a4d232664c0dfe294cc8d6e9f4dfa101340b9da (mode 644) --- /dev/null +++ src/pisol/core.sls @@ -0,0 +1,337 @@ +(library + (pisol core) + (export make-empty-configuration + load-configuration + global-init-path + save-configuration! + configuration-project-path + configuration-config-path + configuration-writable-directories + configuration-outbound-ports + configuration-preserved-arguments + configuration-local-writable-directories + configuration-local-outbound-ports + configuration-baseline-arguments + configuration-source-style + configuration-dirty? + add-directory! + remove-directory! + add-port! + remove-port! + port-valid? + canonical-directory + path-within? + shell-quote + config->shell + string-prefix? + partition-arguments) + (import (chezscheme)) + + (define-record-type configuration + (fields project-path + config-path + (mutable baseline-arguments) + (mutable local-writable-directories) + (mutable local-outbound-ports) + (mutable local-preserved-arguments) + (mutable writable-directories) + (mutable outbound-ports) + (mutable preserved-arguments) + (mutable source-style) + (mutable dirty?))) + + (define (make-empty-configuration project-path config-path) + (make-configuration project-path config-path '() '() '() '() '() '() '() 'absent #f)) + + (define (string-prefix? prefix text) + (and (<= (string-length prefix) (string-length text)) + (string=? prefix (substring text 0 (string-length prefix))))) + + (define (string-suffix? suffix text) + (and (<= (string-length suffix) (string-length text)) + (string=? suffix + (substring text + (- (string-length text) (string-length suffix)) + (string-length text))))) + + (define (trim text) + (let left ([start 0]) + (if (and (< start (string-length text)) + (char-whitespace? (string-ref text start))) + (left (+ start 1)) + (let right ([end (string-length text)]) + (if (and (> end start) + (char-whitespace? (string-ref text (- end 1)))) + (right (- end 1)) + (substring text start end)))))) + + (define (canonical-directory path) + (guard (condition (else #f)) + (and (string? path) + (> (string-length path) 0) + (file-directory? path) + (parameterize ([current-directory path]) (current-directory))))) + + (define (path-within? path root) + (or (string=? path root) + (let ([prefix (if (string-suffix? "/" root) root (string-append root "/"))]) + (string-prefix? prefix path)))) + + (define (port-valid? port) + (and (integer? port) (exact? port) (<= 1 port 65535))) + + (define (append-unique items item) + (if (member item items) items (append items (list item)))) + + (define (remove-equal items item) + (filter (lambda (candidate) (not (equal? candidate item))) items)) + + (define (unique items) + (let loop ([remaining items] [seen '()]) + (if (null? remaining) + (reverse seen) + (if (member (car remaining) seen) + (loop (cdr remaining) seen) + (loop (cdr remaining) (cons (car remaining) seen)))))) + + (define (recompute-effective! configuration) + (let-values ([(base-dirs base-ports base-preserved) + (partition-arguments (configuration-baseline-arguments configuration))]) + (let ([local-dirs (configuration-local-writable-directories configuration)] + [local-ports (configuration-local-outbound-ports configuration)] + [local-preserved (configuration-local-preserved-arguments configuration)]) + (configuration-writable-directories-set! + configuration + (unique (append base-dirs local-dirs))) + (configuration-outbound-ports-set! + configuration + (sort < (unique (append base-ports local-ports)))) + (configuration-preserved-arguments-set! + configuration + (unique (append base-preserved local-preserved)))))) + + (define (add-directory! configuration path) + (let ([directory (canonical-directory path)] + [project (configuration-project-path configuration)]) + (if (or (not directory) + (path-within? directory project) + (member directory (configuration-writable-directories configuration))) + #f + (begin + (configuration-local-writable-directories-set! + configuration + (append (configuration-local-writable-directories configuration) (list directory))) + (recompute-effective! configuration) + (configuration-dirty?-set! configuration #t) + #t)))) + + (define (remove-directory! configuration directory) + (if (not (member directory (configuration-local-writable-directories configuration))) + #f + (begin + (configuration-local-writable-directories-set! + configuration + (remove-equal (configuration-local-writable-directories configuration) directory)) + (recompute-effective! configuration) + (configuration-dirty?-set! configuration #t) + #t))) + + (define (add-port! configuration port) + (if (or (not (port-valid? port)) + (member port (configuration-outbound-ports configuration))) + #f + (begin + (configuration-local-outbound-ports-set! + configuration + (sort < (append (configuration-local-outbound-ports configuration) (list port)))) + (recompute-effective! configuration) + (configuration-dirty?-set! configuration #t) + #t))) + + (define (remove-port! configuration port) + (if (not (member port (configuration-local-outbound-ports configuration))) + #f + (begin + (configuration-local-outbound-ports-set! + configuration + (remove-equal (configuration-local-outbound-ports configuration) port)) + (recompute-effective! configuration) + (configuration-dirty?-set! configuration #t) + #t))) + + (define (shell-quote text) + (let-values ([(port extract) (open-string-output-port)]) + (display "'" port) + (for-each (lambda (character) + (if (char=? character #\') + (display "'\\''" port) + (write-char character port))) + (string->list text)) + (display "'" port) + (extract))) + + (define (read-text path) + (call-with-input-file path get-string-all)) + + (define (canonical-source? text) + (let ([text (trim text)]) + (or (string-prefix? "# Generated by pisol\nargs+=(" text) + (string-prefix? "args+=(\n" text) + (string-prefix? "args=(\n" text)))) + + (define (temporary-path stem) + (format "~a.pisol.~a" stem (time-nanosecond (current-time)))) + + (define (bytevector->nul-strings bytes) + (let loop ([at 0] [current '()] [result '()]) + (cond + [(= at (bytevector-length bytes)) + (reverse (if (null? current) + result + (cons (utf8->string (u8-list->bytevector (reverse current))) result)))] + [(= (bytevector-u8-ref bytes at) 0) + (loop (+ at 1) + '() + (cons (utf8->string (u8-list->bytevector (reverse current))) result))] + [else + (loop (+ at 1) (cons (bytevector-u8-ref bytes at) current) result)]))) + + (define (evaluate-config path) + (let* ([tmpbase (format "~a/pisol-eval-~a" + (or (getenv "TMPDIR") "/tmp") + (time-nanosecond (current-time)))] + [output (string-append tmpbase ".args")] + [errors (string-append tmpbase ".errors")] + [script "args=(); source \"$1\"; if ((${#args[@]})); then printf '%s\\0' \"${args[@]}\"; fi"] + [command (string-append "bash -c " (shell-quote script) + " pisol-config " (shell-quote path) + ">" (shell-quote output) + " 2>" (shell-quote errors))]) + (dynamic-wind + (lambda () #f) + (lambda () + (let ([status (system command)]) + (unless (zero? status) + (error 'load-configuration + (if (file-exists? errors) + (trim (read-text errors)) + "configuration evaluation failed") + path)) + (let ([port (open-file-input-port output)]) + (let ([bytes (get-bytevector-all port)]) + (close-port port) + (if (eof-object? bytes) + '() + (bytevector->nul-strings bytes)))))) + (lambda () + (when (file-exists? output) (delete-file output)) + (when (file-exists? errors) (delete-file errors)))))) + + (define (digits? text) + (and (> (string-length text) 0) + (for-all char-numeric? (string->list text)))) + + (define (normalize-loaded-directory path) + (or (canonical-directory path) path)) + + (define (partition-arguments arguments) + (let loop ([remaining arguments] [directories '()] [ports '()] [preserved '()]) + (cond + [(null? remaining) + (values directories (sort < ports) preserved)] + [(string=? (car remaining) "--rwx") + (when (null? (cdr remaining)) + (error 'load-configuration "missing value for --rwx")) + (let ([directory (normalize-loaded-directory (cadr remaining))]) + (loop (cddr remaining) + (append-unique directories directory) + ports + preserved))] + [(string=? (car remaining) "--connect-tcp") + (when (null? (cdr remaining)) + (error 'load-configuration "missing value for --connect-tcp")) + (let* ([text (cadr remaining)] + [port (and (digits? text) (string->number text))]) + (unless (port-valid? port) + (error 'load-configuration "invalid --connect-tcp port" text)) + (loop (cddr remaining) + directories + (append-unique ports port) + preserved))] + [else + (loop (cdr remaining) + directories + ports + (append preserved (list (car remaining))))]))) + + (define (global-init-path) + (or (getenv "PISOL_INIT_CONFIG") + (let ([xdg (getenv "XDG_CONFIG_HOME")] + [home (getenv "HOME")]) + (and (or xdg home) + (string-append (or xdg (string-append home "/.config")) + "/pisol/init"))))) + + (define (load-configuration project-path config-path) + (let ([project (or (canonical-directory project-path) + (error 'load-configuration "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) + '())] + [local-exists? (file-exists? config-path)] + [source-style (if local-exists? + (if (canonical-source? (read-text config-path)) 'canonical 'custom) + 'absent)] + [local-args (if local-exists? (evaluate-config config-path) '())]) + (let-values ([(base-dirs base-ports base-preserved) (partition-arguments baseline-args)] + [(local-dirs local-ports local-preserved) (partition-arguments local-args)]) + (let ([config (make-configuration project + config-path + baseline-args + local-dirs + local-ports + local-preserved + '() + '() + '() + source-style + #f)]) + (recompute-effective! config) + config))))) + + (define (config->shell configuration) + (let-values ([(port extract) (open-string-output-port)]) + (display "args+=(\n" port) + (for-each (lambda (argument) + (display " " port) + (display (shell-quote argument) port) + (newline port)) + (configuration-local-preserved-arguments configuration)) + (for-each (lambda (directory) + (display " --rwx " port) + (display (shell-quote directory) port) + (newline port)) + (configuration-local-writable-directories configuration)) + (for-each (lambda (tcp-port) + (format port " --connect-tcp ~a~%" tcp-port)) + (configuration-local-outbound-ports configuration)) + (display ")\n" port) + (extract))) + + (define (save-configuration! configuration) + (let* ([path (configuration-config-path configuration)] + [temporary (temporary-path path)]) + (guard (condition + (else + (when (file-exists? temporary) (delete-file temporary)) + (raise condition))) + (call-with-output-file temporary + (lambda (port) (display (config->shell configuration) port)) + 'replace) + (chmod temporary #o600) + (rename-file temporary path) + (configuration-source-style-set! configuration 'canonical) + (configuration-dirty?-set! configuration #f) + #t))) +) blob - /dev/null blob + e0c2d19202e9d0d7e6b2e814e3a9bbf5a726ca3e (mode 644) --- /dev/null +++ src/pisol/tui.sls @@ -0,0 +1,313 @@ +(library + (pisol tui) + (export run-tui) + (import (chezscheme) + (pisol core)) + + (define esc (string (integer->char 27))) + (define color? (not (getenv "NO_COLOR"))) + + (define (ansi code text) + (if color? (string-append esc "[" code "m" text esc "[0m") text)) + (define (cyan text) (ansi "38;2;155;246;255" text)) + (define (green text) (ansi "38;2;202;255;191" 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 (trim text) + (let left ([start 0]) + (if (and (< start (string-length text)) + (char-whitespace? (string-ref text start))) + (left (+ start 1)) + (let right ([end (string-length text)]) + (if (and (> end start) + (char-whitespace? (string-ref text (- end 1)))) + (right (- end 1)) + (substring text start end)))))) + + (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))])))) + + (define (read-input prompt) + (display prompt) + (flush-output-port (current-output-port)) + (let ([line (get-line (current-input-port))]) + (and (not (eof-object? line)) line))) + + (define (command-available? command) + (zero? (system (string-append "command -v " command " >/dev/null 2>&1")))) + + (define (terminal-input?) + (zero? (system "test -t 0"))) + + (define (temporary-path) + (string-append (or (getenv "TMPDIR") "/tmp") + "/pisol-fzf-" + (number->string (time-nanosecond (current-time))))) + + (define (read-first-line path) + (and (file-exists? path) + (call-with-input-file path + (lambda (port) + (let ([line (get-line port)]) + (and (not (eof-object? line)) line)))))) + + (define (read-output-lines path) + (and (file-exists? path) + (call-with-input-file path + (lambda (port) + (let ([first (get-line port)]) + (if (eof-object? first) + #f + (let ([second (get-line port)]) + (list first + (if (eof-object? second) #f second))))))))) + (define (read-text path) + (call-with-input-file path get-string-all)) + + (define (fuzzy-directory base) + (if (or (not (terminal-input?)) + (not (command-available? "fzf")) + (not (file-directory? base))) + base + (let* ([output (temporary-path)] + [fd? (command-available? "fd")] + [child-list (lambda (dir) + (if fd? + (string-append "fd --absolute-path --type directory " + "--hidden --exclude .git --max-depth 1 . " + (shell-quote dir) " 2>/dev/null") + (string-append "find " (shell-quote dir) + " -maxdepth 1 -type d 2>/dev/null")))] + [initial (child-list base)] + [reload (child-list "{+1}")] + [command + (string-append + "{ " initial "; } " + "| fzf --scheme=path --layout=reverse --height=80% --border" + " --expect=esc" + " --prompt='Directory path: '" + " --header='Enter drills down. Alt+Enter or Ctrl-S selects. Esc uses the typed path.'" + " --bind 'enter:reload(" reload ")+clear-query'" + " --bind 'alt-enter:accept'" + " --bind 'ctrl-s:accept'" + " >" (shell-quote output))]) + (dynamic-wind + (lambda () #f) + (lambda () + (let ([status (system command)]) + (cond + [(not (zero? status)) #f] + [else + (let ([lines (read-output-lines output)]) + (cond + [(not lines) base] + [(string=? (car lines) "esc") base] + [else + (let ([selection (cadr lines)]) + (if (and selection (not (string=? (trim selection) ""))) + selection + base))]))]))) + (lambda () + (when (file-exists? output) (delete-file output))))))) + + (define (choose-directory) + (let* ([home (getenv "HOME")] + [default (or home "")] + [prompt (if (string=? default "") + "Directory path: " + (string-append "Directory path [" default "]: "))] + [entry (read-input prompt)]) + (and entry + (let ([base (trim entry)]) + (if (string=? base "") + (and (not (string=? default "")) + (fuzzy-directory default)) + (fuzzy-directory base)))))) + + (define (yes? prompt) + (let ([answer (read-input (string-append prompt " [y/N] "))]) + (and answer + (member (string-downcase (trim answer)) '("y" "yes")) + #t))) + + (define (integer-text text) + (and (> (string-length text) 0) + (for-all char-numeric? (string->list text)) + (string->number text))) + + (define (items-not-in items excluded) + (filter (lambda (item) (not (member item excluded))) items)) + + (define (show-config-files configuration) + (clear-screen) + (display (intense "pisol configuration files")) + (newline) + (newline) + (display (cyan "Global init")) + (newline) + (let ([global (global-init-path)]) + (cond + [(not global) + (display (yellow "not configured")) + (newline)] + [else + (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 configuration)]) + (display (muted local)) + (newline) + (if (file-exists? local) + (display (read-text local)) + (display (yellow "absent"))) + (newline)) + (read-input "Press enter to return. ")) + + (define (render configuration status) + (clear-screen) + (display (intense "pisol ยท isolation")) + (newline) + (display (muted "config: ")) + (display (configuration-config-path configuration)) + (when (eq? (configuration-source-style configuration) 'custom) + (display (yellow " custom shell"))) + (newline) + (newline) + (display (cyan "Writable directories")) + (newline) + (let ([local-dirs (configuration-local-writable-directories configuration)]) + (if (null? local-dirs) + (begin (display (muted " none")) (newline)) + (let loop ([items local-dirs] [index 1]) + (unless (null? items) + (format #t "~3d ~a~%" index (car items)) + (loop (cdr items) (+ index 1)))))) + (newline) + (display (cyan "Outbound TCP ports")) + (newline) + (let ([local-ports (configuration-local-outbound-ports configuration)]) + (if (null? local-ports) + (begin (display (muted " none")) (newline)) + (begin + (display " ") + (for-each (lambda (port) (format #t "~a " port)) local-ports) + (newline)))) + (newline) + (display "a add dir r remove dir p add port d remove port") + (newline) + (display "s save sx save exit c show config ? help x exit") + (newline) + (when (configuration-dirty? configuration) + (display (yellow "unsaved changes")) + (newline)) + (when (and status (not (string=? status ""))) + (display (if (string-prefix? "saved" status) (green status) (yellow status))) + (newline))) + + (define (show-help) + (clear-screen) + (display (intense "pisol help")) + (newline) + (newline) + (display "Enter a base path; fuzzy selection lists it and its immediate children.") + (newline) + (display "Cancel the picker to use the typed path directly.") + (newline) + (display "The baseline writable tree cannot be added again. TCP is denied unless listed.") + (newline) + (newline) + (display "Existing custom .isolate shell is trusted and evaluated. Saving it replaces") + (newline) + (display "the source with the canonical evaluated Landrun argument list.") + (newline) + (display "c shows the raw global and local configuration files.") + (newline) + (read-input "Press enter to return. ")) + + (define (run-tui configuration) + (let loop ([status ""]) + (render configuration status) + (let ([input (read-input "> ")]) + (if (not input) + #t + (let-values ([(command argument) (split-command input)]) + (cond + [(string=? command "a") + (let ([path (choose-directory)]) + (cond + [(not path) #t] + [(string=? (trim path) "") (loop "directory path is required")] + [(add-directory! configuration (trim path)) + (loop (string-append "added " (trim path)))] + [else + (loop "directory is missing, duplicated, or already writable")]))] + [(string=? command "r") + (let ([directories (configuration-local-writable-directories configuration)]) + (if (null? directories) + (loop "no writable directory to remove") + (let ([index (let ([given (or (and (> (string-length argument) 0) (integer-text argument)) + (let ([text (read-input "Directory number: ")]) + (and text (integer-text (trim text)))))]) + (and given (integer? given) given))]) + (if (and index (<= 1 index (length directories))) + (begin + (remove-directory! configuration + (list-ref directories (- 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! configuration 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 configuration)]) + (if (null? ports) + (loop "no outbound TCP port to remove") + (let ([port (let ([given (or (and (> (string-length argument) 0) (integer-text argument)) + (let ([text (read-input "Port: ")]) + (and text (integer-text (trim text)))))]) + (and given (integer? given) given))]) + (if (and port (remove-port! configuration port)) + (loop (format "removed outbound TCP port ~a" port)) + (loop "configured port not found")))))] + [(or (string=? command "s") (string=? command "sx") (string=? command "xs")) + (cond + [(not (configuration-dirty? configuration)) + (if (string=? command "s") (loop "nothing to save") #t)] + [(and (eq? (configuration-source-style configuration) 'custom) + (not (yes? "Replace custom shell with canonical evaluated arguments?"))) + (if (string=? command "s") (loop "save cancelled") #t)] + [else + (guard (condition + (else (loop (format "save failed: ~a" condition)))) + (save-configuration! configuration) + (if (or (string=? command "sx") (string=? command "xs")) #t (loop "saved .isolate")))])] + [(string=? command "?") (show-help) (loop "")] + [(string=? command "c") (show-config-files configuration) (loop "")] + [(string=? command "x") #t] + [(string=? command "") (loop status)] + [else (loop "unknown command; enter ? for help")])))))) +) blob - /dev/null blob + 6b778faeb157579442fdc80a46aa8618606bdea4 (mode 755) --- /dev/null +++ test/integration.sh @@ -0,0 +1,128 @@ +#!/bin/sh +set -eu + +project_root=$(CDPATH='' cd -- "$(dirname -- "$0")/.." && pwd) +test_root=${TMPDIR:-/tmp}/pisol-integration.$$ +fake_bin=$test_root/bin +project=$test_root/project +home=$test_root/home +capture=$test_root/landrun.args +trap 'rm -rf "$test_root"' 0 HUP INT TERM +mkdir -p "$fake_bin" "$project" "$home" "$home/extra dir" + +cat >"$fake_bin/landrun" <<'EOF' +#!/bin/sh +set -eu +: "${PISOL_TEST_CAPTURE:?}" +printf '%s\0' "$@" >"$PISOL_TEST_CAPTURE" +while [ "$#" -gt 0 ] && [ "$1" != -- ]; do shift; done +[ "$#" -gt 0 ] && shift +exec "$@" +EOF +chmod +x "$fake_bin/landrun" + +run_pisol() { + ( + cd "$project" + PATH=$fake_bin:$PATH \ + HOME=$home \ + PISOL_RUNTIME_DIR=$project_root/build/runtime \ + PISOL_TEST_CAPTURE=$capture \ + NO_COLOR=1 \ + "$project_root/bin/pisol" "$@" + ) +} + +if run_pisol -- sh -c 'exit 7'; then + echo "pisol integration: command status was not propagated" >&2 + exit 1 +else + status=$? + [ "$status" -eq 7 ] || exit 1 +fi + +tr '\0' '\n' <"$capture" >"$test_root/args.txt" +grep -Fx -- '--best-effort' "$test_root/args.txt" >/dev/null +grep -Fx -- '--unrestricted-scoped' "$test_root/args.txt" >/dev/null +grep -Fx -- "$project" "$test_root/args.txt" >/dev/null +grep -Fx -- '/dev/null' "$test_root/args.txt" >/dev/null +if grep -Fx -- '--unrestricted-network' "$test_root/args.txt" >/dev/null; then + echo "pisol integration: unrestricted network unexpectedly enabled" >&2 + exit 1 +fi + +printf '%s\n' 'args+=(' ' --connect-tcp 443' " --rwx '$home/extra dir'" ')' >"$project/.isolate" +run_pisol -- sh -c 'exit 0' +tr '\0' '\n' <"$capture" >"$test_root/args.txt" +grep -Fx -- '--connect-tcp' "$test_root/args.txt" >/dev/null +grep -Fx -- '443' "$test_root/args.txt" >/dev/null +grep -Fx -- "$home/extra dir" "$test_root/args.txt" >/dev/null + +before=$(cksum "$capture") +if ISOLATE_ENV=already run_pisol -- sh -c 'exit 9'; then + exit 1 +else + status=$? + [ "$status" -eq 9 ] || exit 1 +fi +[ "$before" = "$(cksum "$capture")" ] + +run_pisol --help | grep -F 'pisol -- COMMAND' >/dev/null + +rm -f "$project/.isolate" +printf 'a\n%s\np 443\ns\nx\n' "$home/extra dir" | run_pisol >"$test_root/tui.out" +grep -F -- "--rwx '$home/extra dir'" "$project/.isolate" >/dev/null +grep -F -- '--connect-tcp 443' "$project/.isolate" >/dev/null +grep -F 'saved' "$test_root/tui.out" >/dev/null +grep -F 'r remove dir' "$test_root/tui.out" >/dev/null +grep -F 'd remove port' "$test_root/tui.out" >/dev/null +if grep -E 'r NUMBER remove dir|d PORT remove' "$test_root/tui.out" >/dev/null; then + echo "pisol integration: removal commands still require inline arguments" >&2 + exit 1 +fi +if grep -E 'project:|p project|h home|browse/add' "$test_root/tui.out" >/dev/null; then + echo "pisol integration: location labels unexpectedly exposed" >&2 + exit 1 +fi + +printf 'r\n1\nd\n443\ns\nx\n' | run_pisol >"$test_root/remove.out" +if grep -F -- '--rwx' "$project/.isolate" >/dev/null || + grep -F -- '--connect-tcp' "$project/.isolate" >/dev/null; then + echo "pisol integration: prompted removal did not remove configuration" >&2 + exit 1 +fi + +saved=$(cksum "$project/.isolate") +printf 'p 8443\n' | run_pisol >/dev/null +[ "$saved" = "$(cksum "$project/.isolate")" ] + +printf '%s\n' 'if true; then args+=(--ro /custom); fi' >"$project/.isolate" +custom=$(cksum "$project/.isolate") +printf 'p 80\ns\nn\nx\ny\n' | run_pisol >/dev/null +[ "$custom" = "$(cksum "$project/.isolate")" ] + +# Global init defaults are sourced before the local .isolate. +global_init=$home/.config/pisol/init +mkdir -p "$(dirname "$global_init")" +printf '%s\n' 'args+=(' " --rwx '$home/extra dir'" ')' >"$global_init" +rm -f "$project/.isolate" +run_pisol -- sh -c 'exit 0' +tr '\0' '\n' <"$capture" >"$test_root/args.txt" +grep -Fx -- "$home/extra dir" "$test_root/args.txt" >/dev/null + +# Local .isolate builds on top of the global init. +printf '%s\n' 'args+=( --connect-tcp 443 )' >"$project/.isolate" +run_pisol -- sh -c 'exit 0' +tr '\0' '\n' <"$capture" >"$test_root/args.txt" +grep -Fx -- "$home/extra dir" "$test_root/args.txt" >/dev/null +grep -Fx -- '443' "$test_root/args.txt" >/dev/null + +# show-config command prints both global and local configuration files. +printf 'c\n\nx\n' | run_pisol >"$test_root/showconfig.out" +grep -F 'c show config' "$test_root/showconfig.out" >/dev/null +grep -F -- "$global_init" "$test_root/showconfig.out" >/dev/null +grep -F -- "$project/.isolate" "$test_root/showconfig.out" >/dev/null +grep -F -- "$home/extra dir" "$test_root/showconfig.out" >/dev/null +grep -F -- '--connect-tcp 443' "$test_root/showconfig.out" >/dev/null + +printf 'pisol: shell and TUI integration checks passed\n' blob - /dev/null blob + 85973c99742e293da98399d3d3720c476ffd4a8a (mode 644) --- /dev/null +++ test/test.ss @@ -0,0 +1,200 @@ +#!/usr/bin/env scheme --program +(import (chezscheme) + (pisol core)) + +(define checks 0) +(define (check value message) + (set! checks (+ checks 1)) + (unless value (error 'pisol-test message))) + +(define (check-equal actual expected message) + (check (equal? actual expected) + (format "~a: expected ~s, got ~s" message expected actual))) + +(define (mkdir-p path) + (unless (file-exists? path) (mkdir path))) + +(define (write-text path text) + (call-with-output-file path + (lambda (port) (display text port)) + 'replace)) + +(define (read-text path) + (call-with-input-file path get-string-all)) + +(define (string-contains? haystack needle) + (let ([n (string-length needle)] + [m (string-length haystack)]) + (let loop ([i 0]) + (cond + [(> i (- m n)) #f] + [(string=? (substring haystack i (+ i n)) needle) #t] + [else (loop (+ i 1))])))) + +(define (temporary-root) + (let ([path (format "/tmp/pisol-test-~a" (time-nanosecond (current-time)))]) + (mkdir-p path) + path)) + +;; Isolate tests from the developer's real HOME config. +(define test-home (temporary-root)) +(putenv "HOME" test-home) + +(define (port-tests) + (check (port-valid? 1) "minimum port is valid") + (check (port-valid? 65535) "maximum port is valid") + (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") + (let ([configuration (make-empty-configuration "/project" "/project/.isolate")]) + (check (add-port! configuration 443) "add a valid port") + (check-equal (configuration-outbound-ports configuration) '(443) "port is exposed") + (check (not (add-port! configuration 443)) "duplicate port rejected") + (check (configuration-dirty? configuration) "adding marks configuration dirty") + (check (remove-port! configuration 443) "remove existing port") + (check (not (remove-port! configuration 443)) "missing port removal rejected") + (check-equal (configuration-outbound-ports configuration) '() "port removed"))) + +(define (directory-tests) + (let* ([root (temporary-root)] + [project (string-append root "/project")] + [outside (string-append root "/outside")] + [inside (string-append project "/inside")] + [missing (string-append root "/missing")]) + (mkdir-p project) + (mkdir-p outside) + (mkdir-p inside) + (let ([configuration (make-empty-configuration project (string-append project "/.isolate"))]) + (check (add-directory! configuration outside) "add an existing outside directory") + (check (not (add-directory! configuration outside)) "duplicate directory rejected") + (check (not (add-directory! configuration project)) "project directory is redundant") + (check (not (add-directory! configuration inside)) "project child is redundant") + (check (not (add-directory! configuration missing)) "missing directory rejected") + (check-equal (configuration-writable-directories configuration) + (list outside) + "canonical writable directories exposed") + (check (remove-directory! configuration outside) "remove existing directory") + (check (not (remove-directory! configuration outside)) "missing directory removal rejected")))) + +(define (quote-tests) + (check-equal (shell-quote "plain") "'plain'" "simple shell quote") + (check-equal (shell-quote "a b") "'a b'" "space shell quote") + (check-equal (shell-quote "it's") "'it'\\''s'" "apostrophe shell quote")) + +(define (configuration-tests) + (let* ([root (temporary-root)] + [project (string-append root "/project")] + [outside (string-append root "/outside dir's")] + [path (string-append project "/.isolate")]) + (mkdir-p project) + (mkdir-p outside) + (write-text path + (string-append "args+=(\n" + " --ro '/opt/data'\n" + " --rwx '" root "/outside dir'\\''s'\n" + " --connect-tcp 443\n" + ")\n")) + (let ([configuration (load-configuration project path)]) + (check-equal (configuration-source-style configuration) 'canonical "canonical source detected") + (check-equal (configuration-preserved-arguments configuration) + '("--ro" "/opt/data") + "opaque arguments retained") + (check-equal (configuration-writable-directories configuration) + (list outside) + "writable path loaded") + (check-equal (configuration-outbound-ports configuration) '(443) "port loaded") + (check (not (configuration-dirty? configuration)) "loaded configuration is clean") + (check (add-port! configuration 8443) "loaded configuration can be edited") + (save-configuration! configuration) + (check (not (configuration-dirty? configuration)) "save clears dirty state") + (check-equal (configuration-source-style configuration) 'canonical "save canonicalizes source") + (let ([again (load-configuration project path)]) + (check-equal (configuration-preserved-arguments again) + '("--ro" "/opt/data") + "opaque arguments survive save") + (check-equal (configuration-outbound-ports again) '(443 8443) "ports survive save") + (check (string-prefix? "args+=(\n" (read-text path)) + "canonical header written"))) + (write-text path "if [ -n \"${HOME:-}\" ]; then args+=(--ro \"$HOME\"); fi\n") + (let ([custom (load-configuration project path)]) + (check-equal (configuration-source-style custom) 'custom "custom shell detected") + (check-equal (configuration-preserved-arguments custom) + (list "--ro" (getenv "HOME")) + "custom shell evaluated as trusted config")) + (write-text path "args=()\n") + (let ([empty (load-configuration project path)]) + (check-equal (configuration-preserved-arguments empty) '() "empty argument array loads") + (check-equal (configuration-writable-directories empty) '() "empty config has no directories") + (check-equal (configuration-outbound-ports empty) '() "empty config has no ports")) + (write-text path "args+=(--connect-tcp 0)\n") + (check (guard (condition (else #t)) (load-configuration project path) #f) + "invalid recognized port rejects config") + (write-text path "args+=(--rwx)\n") + (check (guard (condition (else #t)) (load-configuration project path) #f) + "missing recognized operand rejects config"))) + +(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) + (putenv "HOME" home) + (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 ([configuration (load-configuration project path)]) + (check-equal (configuration-source-style configuration) 'canonical + "canonical local source detected with baseline") + (check-equal (configuration-preserved-arguments configuration) + '("--ro" "/opt/global") + "global preserved arguments merged") + (check-equal (configuration-writable-directories configuration) + (list outside) + "global writable directory merged") + (check-equal (configuration-outbound-ports configuration) + '(80 443) + "global and local ports merged") + (check-equal (configuration-local-outbound-ports configuration) + '(443) + "local port stored separately") + (check (not (configuration-dirty? configuration)) "loaded baseline config is clean") + (check (not (add-directory! configuration outside)) "duplicate global directory rejected") + (check (not (remove-directory! configuration outside)) "global directory cannot be removed here") + (check (add-port! configuration 8080) "local port added on top of baseline") + (save-configuration! configuration) + (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")) + (putenv "HOME" test-home))) + +(port-tests) +(directory-tests) +(quote-tests) +(configuration-tests) +(baseline-tests) +(format #t "pisol: ~a Chez checks passed~%" checks) blob - /dev/null blob + 67f19c99c35860f7184778309e55ad208e993212 (mode 644) --- /dev/null +++ tools/build.ss @@ -0,0 +1,3 @@ +(import (chezscheme)) +(compile-program "bin/pisol.ss" "build/runtime/pisol.so") + blob - /dev/null blob + e97283066235c2f176a19ce9bd6d6e278182618d (mode 755) --- /dev/null +++ tools/fmt.sh @@ -0,0 +1,24 @@ +#!/bin/sh +set -eu + +fmt_file() { + file=$1 + emacs --batch \ + --eval "(require 'scheme)" \ + --eval "(setq-default indent-tabs-mode nil)" \ + --eval "(setq lisp-body-indent 2)" \ + --eval "(put 'library 'scheme-indent-function (lambda (&rest _) 1))" \ + --eval "(put 'cond 'scheme-indent-function 0)" \ + --eval "(put 'dynamic-wind 'scheme-indent-function 0)" \ + --eval "(put 'lambda 'scheme-indent-function 'defun)" \ + --eval "(find-file \"$file\")" \ + --eval "(indent-region (point-min) (point-max) nil)" \ + --eval "(save-buffer)" >/dev/null 2>&1 + if head -n1 "$file" | grep -q '^(library'; then + sed -i -E '${/^[[:space:]]*\)+[[:space:]]*$/s/^[[:space:]]*//}' "$file" + fi +} + +for file in "$@"; do + fmt_file "$file" +done