commit - 8d770450250cef56e61239916df4b54abc0cfebf
commit + d26b78f71c23ec0a7f30faf440d8c138327e1394
blob - 56149432a994999960a06ea4683bf3a81755118c
blob + 78c916cf9665cc833a7eccbaee454e2e2472d234
--- .gitignore
+++ .gitignore
/build/
/src/pisol/*.so
+/src/pisol/*.o
+/src/pisol/*.import.scm
+/*.import.scm
/.ninja_log
blob - d85efa1ca93a57cd04628489694cf94b918201d6
blob + 4724188ce7713e8e276bf6ad80537f52fa2b8d5a
--- Makefile
+++ Makefile
INSTALL ?= install
RM ?= rm -f
-SCHEME ?= scheme
+CSC ?= csc
+CSC_LINK_FLAGS ?= -static
.PHONY: build tui test copy-config clean run 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 src --compile-imported-libraries --program tools/build.ss
- cp src/pisol/core.so src/pisol/tui.so build/runtime/lib/pisol/
+
+build: build/runtime/pisol
+
+CORE_O = build/runtime/pisol.core.o
+TUI_O = build/runtime/pisol.tui.o
+
+build/runtime:
+ @mkdir -p build/runtime
+
+$(CORE_O): src/pisol/core.scm | build/runtime
+ @cd build/runtime && $(CSC) -c -unit pisol.core -j pisol.core -o pisol.core.o ../../src/pisol/core.scm
+
+$(TUI_O): src/pisol/tui.scm $(CORE_O) | build/runtime
+ @cd build/runtime && $(CSC) -c -unit pisol.tui -j pisol.tui -o pisol.tui.o -I. ../../src/pisol/tui.scm
+
+build/runtime/pisol: bin/pisol.scm $(CORE_O) $(TUI_O)
+ @cd build/runtime && $(CSC) $(CSC_LINK_FLAGS) -I. -o pisol ../../bin/pisol.scm pisol.core.o pisol.tui.o
+
tui: build
- $(SCHEME) --libdirs src --program bin/pisol.ss
+ build/runtime/pisol
+
test: build
shellcheck bin/pisol test/integration.sh
- $(SCHEME) --libdirs src --program test/test.ss
+ csi -s test/test.scm
sh test/integration.sh
+
copy-config:
@target="$${XDG_CONFIG_HOME:-$$HOME/.config}/pisol/init"; \
[ ! -e "$$target" ] || { printf 'pisol: %s already exists\n' "$$target" >&2; exit 1; }; \
$(INSTALL) -d "$${target%/*}" && $(INSTALL) -m 644 config/pisol/init "$$target"
+
clean:
- rm -rf build src/pisol/core.so src/pisol/tui.so
+ rm -rf build src/pisol/*.o src/pisol/*.so src/pisol/*.import.scm src/pisol/*.link *.import.scm bin/pisol.c src/pisol/*.c build/runtime/*.o build/runtime/*.import.scm build/runtime/*.link
+
run: install
$(DESTDIR)$(BINDIR)/pisol
+
install: build
- $(INSTALL) -d $(DESTDIR)$(BINDIR) $(DESTDIR)$(LIBEXECDIR)/lib/pisol $(DESTDIR)$(MANDIR)/man1
+ $(INSTALL) -d $(DESTDIR)$(BINDIR) $(DESTDIR)$(LIBEXECDIR) $(DESTDIR)$(MANDIR)/man1
$(INSTALL) -m 755 bin/pisol $(DESTDIR)$(BINDIR)/pisol
- $(INSTALL) -m 755 build/runtime/pisol.so $(DESTDIR)$(LIBEXECDIR)/pisol.so
- $(INSTALL) -m 644 build/runtime/lib/pisol/core.so build/runtime/lib/pisol/tui.so $(DESTDIR)$(LIBEXECDIR)/lib/pisol/
+ $(INSTALL) -m 755 build/runtime/pisol $(DESTDIR)$(LIBEXECDIR)/pisol
$(INSTALL) -m 644 doc/pisol.1 $(DESTDIR)$(MANDIR)/man1/pisol.1
+
uninstall:
- $(RM) $(DESTDIR)$(BINDIR)/pisol $(DESTDIR)$(LIBEXECDIR)/pisol.so
- $(RM) $(DESTDIR)$(LIBEXECDIR)/lib/pisol/core.so $(DESTDIR)$(LIBEXECDIR)/lib/pisol/tui.so
+ $(RM) $(DESTDIR)$(BINDIR)/pisol $(DESTDIR)$(LIBEXECDIR)/pisol
$(RM) $(DESTDIR)$(MANDIR)/man1/pisol.1
+
help:
@printf '%s\n' \
'make build Compile pisol' \
'' \
'Variables: PREFIX=/usr/local DESTDIR= BINDIR=PREFIX/bin' \
' LIBEXECDIR=PREFIX/libexec/pisol MANDIR=PREFIX/share/man' \
- ' SCHEME=scheme INSTALL=install'
+ ' CSC=csc INSTALL=install'
blob - e64a081a9d55296ded0da4d035996f21e4b889c5
blob + 824323346cc9d8c5eaebfa7539ad0fd62cc8db02
--- README.md
+++ README.md
## Requirements
- Bash
-- Chez Scheme 10.4 or later
+- CHICKEN Scheme 5.4 or later
- Make
- A sandbox backend for the host:
- Linux: [Landrun](https://github.com/Zouuup/landrun)
```
`make install` uses `/usr/local`. Set `PREFIX`, `DESTDIR`, `BINDIR`,
-`LIBEXECDIR`, `MANDIR` or `SCHEME` to change build or install paths.
+`LIBEXECDIR`, `MANDIR` or `CSC` to change build or install paths.
blob - c1bff999d1f4288c3f057e07c3219d1e3bf4f67c
blob + 682abbcb9672b57ea97d350659f1acd31ff59185
--- bin/pisol
+++ bin/pisol
"")
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" \
+ exec "$pisol_runtime_dir/pisol" \
--project "$pisol_project" \
--config "$pisol_config"
;;
blob - 2f97d60ac340181b0b19b09d563daabedaf13fda (mode 644)
blob + /dev/null
--- bin/pisol.ss
+++ /dev/null
-#!/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 + 2048da2ac2f1da716005271ddb8a5dab5b268efa (mode 644)
--- /dev/null
+++ bin/pisol.scm
+(import scheme (chicken base) (chicken condition)
+ (chicken process-context) pisol.core pisol.tui)
+
+(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))))))
+
+(handle-exceptions exn
+ (begin
+ (display "pisol: " (current-error-port))
+ (print-error-message exn (current-error-port))
+ (newline (current-error-port))
+ (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)))
+ (config (or config-argument
+ (get-environment-variable "ISOLATE_EXTRA_CONFIG")
+ (string-append project "/.isolate"))))
+ (run-tui (load-configuration project config)))))
blob - 161ad5841e7f4e40759a089851e13603e0ad5d23 (mode 644)
blob + /dev/null
--- src/pisol/core.sls
+++ /dev/null
-(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)
- (let ([now (current-time)])
- (format "~a.pisol.~a.~a"
- stem
- (time-second now)
- (time-nanosecond now))))
-
- (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 ([bytes (call-with-port (open-file-input-port output)
- get-bytevector-all)])
- (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))
- '())
- (chmod temporary #o600)
- (rename-file temporary path)
- (configuration-source-style-set! configuration 'canonical)
- (configuration-dirty?-set! configuration #f)
- #t)))
-)
blob - /dev/null
blob + ce9f7327bcb45b381c97fc2d891d77552aa52df1 (mode 644)
--- /dev/null
+++ src/pisol/core.scm
+(module pisol.core
+ (make-empty-configuration load-configuration global-init-path save-configuration!
+ configuration-config-path
+ configuration-writable-directories configuration-outbound-ports
+ configuration-preserved-arguments configuration-local-writable-directories
+ 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)
+ (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)
+ (chicken string) (chicken time))
+
+ (define-record-type configuration
+ (make-configuration project-path config-path baseline-arguments local-writable-directories
+ local-outbound-ports local-preserved-arguments writable-directories
+ outbound-ports preserved-arguments source-style dirty?)
+ configuration?
+ (project-path configuration-project-path)
+ (config-path configuration-config-path)
+ (baseline-arguments configuration-baseline-arguments configuration-baseline-arguments-set!)
+ (local-writable-directories configuration-local-writable-directories configuration-local-writable-directories-set!)
+ (local-outbound-ports configuration-local-outbound-ports configuration-local-outbound-ports-set!)
+ (local-preserved-arguments configuration-local-preserved-arguments configuration-local-preserved-arguments-set!)
+ (writable-directories configuration-writable-directories configuration-writable-directories-set!)
+ (outbound-ports configuration-outbound-ports configuration-outbound-ports-set!)
+ (preserved-arguments configuration-preserved-arguments configuration-preserved-arguments-set!)
+ (source-style configuration-source-style configuration-source-style-set!)
+ (dirty? configuration-dirty? configuration-dirty?-set!))
+
+ (define (make-empty-configuration project config)
+ (make-configuration project config '() '() '() '() '() '() '() '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)
+ (let ((n (string-length suffix)) (m (string-length text)))
+ (and (<= n m) (string=? suffix (substring text (- m n))))))
+
+ (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)
+ (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)))))))
+
+ (define (path-within? path root)
+ (or (string=? path root)
+ (string-prefix? (if (string-suffix? "/" root) root (string-append root "/")) 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)
+ (let loop ((items items) (result '()))
+ (if (null? items)
+ (reverse result)
+ (loop (cdr items)
+ (if (equal? (car items) item) result (cons (car items) result))))))
+
+ (define (unique items)
+ (let loop ((items items) (seen '()))
+ (if (null? items)
+ (reverse seen)
+ (let ((item (car items)))
+ (loop (cdr items) (if (member item seen) seen (cons item seen)))))))
+
+ (define (recompute-effective! config)
+ (receive (base-dirs base-ports base-preserved)
+ (partition-arguments (configuration-baseline-arguments config))
+ (configuration-writable-directories-set! config
+ (unique (append base-dirs (configuration-local-writable-directories config))))
+ (configuration-outbound-ports-set! config
+ (sort (unique (append base-ports (configuration-local-outbound-ports config))) <))
+ (configuration-preserved-arguments-set! config
+ (unique (append base-preserved (configuration-local-preserved-arguments config))))))
+
+ (define (add-directory! config path)
+ (let ((directory (canonical-directory path))
+ (project (configuration-project-path config)))
+ (cond ((or (not directory) (path-within? directory project)
+ (member directory (configuration-writable-directories config))) #f)
+ (else
+ (configuration-local-writable-directories-set! config
+ (append (configuration-local-writable-directories config) (list directory)))
+ (recompute-effective! config)
+ (configuration-dirty?-set! config #t)
+ #t))))
+
+ (define (remove-directory! config directory)
+ (if (member directory (configuration-local-writable-directories config))
+ (begin
+ (configuration-local-writable-directories-set! config
+ (remove-equal (configuration-local-writable-directories config) directory))
+ (recompute-effective! config)
+ (configuration-dirty?-set! config #t)
+ #t)
+ #f))
+
+ (define (add-port! config port)
+ (cond ((or (not (port-valid? port)) (member port (configuration-outbound-ports config))) #f)
+ (else
+ (configuration-local-outbound-ports-set! config
+ (sort (append (configuration-local-outbound-ports config) (list port)) <))
+ (recompute-effective! config)
+ (configuration-dirty?-set! config #t)
+ #t)))
+
+ (define (remove-port! config port)
+ (if (member port (configuration-local-outbound-ports config))
+ (begin
+ (configuration-local-outbound-ports-set! config
+ (remove-equal (configuration-local-outbound-ports config) port))
+ (recompute-effective! config)
+ (configuration-dirty?-set! config #t)
+ #t)
+ #f))
+
+ (define (shell-quote text)
+ (let loop ((characters (string->list text)) (result "'"))
+ (if (null? characters)
+ (string-append result "'")
+ (let ((character (car characters)))
+ (loop (cdr characters)
+ (string-append result
+ (if (char=? character #\')
+ "'\\''"
+ (string character))))))))
+
+ (define (read-text path)
+ (call-with-input-file path (lambda (port) (read-string #f port))))
+
+ (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 (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 ()
+ (receive (_ normal? status) (process-wait pid)
+ (unless (and normal? (zero? status))
+ (let* ((raw (read-string #f err))
+ (message (if (eof-object? raw)
+ "configuration evaluation failed"
+ (trim raw))))
+ (error 'load-configuration message path))))
+ (let ((text (read-string #f in)))
+ (if (or (eof-object? text) (zero? (string-length text)))
+ '()
+ (nul-strings text))))
+ (lambda ()
+ (close-input-port in)
+ (close-output-port out)
+ (close-input-port err))))))
+
+ (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)))))))
+
+ (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")
+ (if (null? (cdr remaining))
+ (error 'load-configuration "missing value for --rwx")
+ (loop (cddr remaining)
+ (append-unique directories (normalize-loaded-directory (cadr remaining)))
+ ports
+ preserved)))
+ ((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)))))
+ (if (not (port-valid? port))
+ (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))))))))
+
+ (define (global-init-path)
+ (or (get-environment-variable "PISOL_INIT_CONFIG")
+ (let ((xdg (get-environment-variable "XDG_CONFIG_HOME"))
+ (home (get-environment-variable "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) '())))
+ (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
+ local-dirs local-ports local-preserved
+ '() '() '() source-style #f)))
+ (recompute-effective! config)
+ config))))))
+
+ (define (config->shell config)
+ (with-output-to-string
+ (lambda ()
+ (display "args+=(\n")
+ (for-each (lambda (argument)
+ (printf " ~a~%" (shell-quote argument)))
+ (configuration-local-preserved-arguments config))
+ (for-each (lambda (directory)
+ (printf " --rwx ~a~%" (shell-quote directory)))
+ (configuration-local-writable-directories config))
+ (for-each (lambda (tcp-port)
+ (printf " --connect-tcp ~a~%" tcp-port))
+ (configuration-local-outbound-ports config))
+ (display ")\n"))))
+
+ (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)
+ (when (file-exists? path) (delete-file path))
+ (rename-file temporary path)
+ (configuration-source-style-set! config 'canonical)
+ (configuration-dirty?-set! config #f)
+ #t))))
blob - 6dbe826a2abdfc3295989d4be8f75d976c22b2f3 (mode 644)
blob + /dev/null
--- src/pisol/tui.sls
+++ /dev/null
-(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 (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 (terminal-input?)
- (zero? (system "test -t 0")))
-
- (define (temporary-path)
- (let ([now (current-time)])
- (format "~a/pisol-path-~a.~a"
- (or (getenv "TMPDIR") "/tmp")
- (time-second now)
- (time-nanosecond now))))
-
- (define (read-text path)
- (call-with-input-file path get-string-all))
-
- (define (read-directory-path prompt initial)
- ;; Bash Readline supplies native filename completion on TAB.
- (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)))))))
-
- (define (choose-directory)
- (let* ([home (getenv "HOME")]
- [default (if (and home (file-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))))))
-
- (define (integer-text text)
- (and (> (string-length text) 0)
- (for-all char-numeric? (string->list text))
- (string->number text)))
-
- (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"))
- (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 "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. "))
-
- (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 (trim path) " added"))]
- [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")))))]
- [(string=? command "?") (show-help) (loop "")]
- [(string=? command "c") (show-config-files configuration) (loop "")]
- [(string=? command "x")
- (if (not (configuration-dirty? configuration))
- #t
- (guard (condition
- (else (loop (format "save failed: ~a" condition))))
- (save-configuration! configuration)
- #t))]
- [(string=? command "") (loop status)]
- [else (loop "unknown command; enter ? for help")]))))))
-)
blob - /dev/null
blob + 1f69d2762d5ab78674c417578d4669c2c3f072f3 (mode 644)
--- /dev/null
+++ src/pisol/tui.scm
+(module pisol.tui (run-tui)
+ (import scheme (chicken base) (chicken condition) (chicken file) (chicken file posix) (chicken format)
+ (chicken io) (chicken process) (chicken process-context) (chicken time)
+ 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 (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 (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) (let ((line (read-line))) (and (not (eof-object? line)) line)))
+ (define (terminal-input?) (zero? (system "test -t 0")))
+ (define tui-temporary-counter 0)
+ (define (temporary-path)
+ (set! tui-temporary-counter (+ tui-temporary-counter 1))
+ (string-append (or (get-environment-variable "TMPDIR") "/tmp") "/pisol-path-" (number->string (current-seconds)) "." (number->string tui-temporary-counter)))
+ (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)))))))
+ (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))))))
+ (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)))
+ (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))
+ (read-input "Press enter to return. "))
+ (define (render config status)
+ (clear-screen) (display (intense "pisol")) (newline) (display (muted "config: ")) (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))))))
+ (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. "))
+ (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))
+ (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"))))))))))
blob - 85973c99742e293da98399d3d3720c476ffd4a8a (mode 644)
blob + /dev/null
--- test/test.ss
+++ /dev/null
-#!/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 + 67de22edd1873179fbe15d14cfea8cb8167ed330 (mode 644)
--- /dev/null
+++ test/test.scm
+(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)
+ pisol.core)
+
+(set-environment-variable! "PISOL_INIT_CONFIG" "/tmp/pisol-no-global-init")
+
+(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)
+ (string-append message ": expected "
+ (with-output-to-string (lambda () (write expected)))
+ ", got "
+ (with-output-to-string (lambda () (write actual))))))
+
+(define (mkdir-p path)
+ (unless (file-exists? path) (create-directory path)))
+
+(define (write-text path text)
+ (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))))
+
+(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-counter 0)
+(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))
+
+(define test-home (temporary-root))
+(set-environment-variable! "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 ((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")
+ (check (not (add-port! config 443)) "duplicate port rejected")
+ (check (configuration-dirty? config) "adding marks configuration dirty")
+ (check (remove-port! config 443) "remove existing port")
+ (check (not (remove-port! config 443)) "missing port removal rejected")
+ (check-equal (configuration-outbound-ports config) '() "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 ((config (make-empty-configuration project (string-append project "/.isolate"))))
+ (check (add-directory! config outside) "add an existing outside directory")
+ (check (not (add-directory! config outside)) "duplicate directory rejected")
+ (check (not (add-directory! config project)) "project directory is redundant")
+ (check (not (add-directory! config inside)) "project child is redundant")
+ (check (not (add-directory! config missing)) "missing directory rejected")
+ (check-equal (configuration-writable-directories config) (list outside)
+ "canonical writable directories exposed")
+ (check (remove-directory! config outside) "remove existing directory")
+ (check (not (remove-directory! config 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 ((config (load-configuration project path)))
+ (check-equal (configuration-source-style config) 'canonical "canonical source detected")
+ (check-equal (configuration-preserved-arguments config) '("--ro" "/opt/data")
+ "opaque arguments retained")
+ (check-equal (configuration-writable-directories config) (list outside)
+ "writable path loaded")
+ (check-equal (configuration-outbound-ports config) '(443) "port loaded")
+ (check (not (configuration-dirty? config)) "loaded configuration is clean")
+ (check (add-port! config 8443) "loaded configuration can be edited")
+ (save-configuration! config)
+ (check (not (configuration-dirty? config)) "save clears dirty state")
+ (check-equal (configuration-source-style config) '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" (get-environment-variable "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 (handle-exceptions _ #t (load-configuration project path) #f)
+ "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")))
+
+(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")))
+
+(port-tests)
+(directory-tests)
+(quote-tests)
+(configuration-tests)
+(baseline-tests)
+(format #t "pisol: ~a CHICKEN checks passed~%" checks)
blob - 67f19c99c35860f7184778309e55ad208e993212 (mode 644)
blob + /dev/null
--- tools/build.ss
+++ /dev/null
-(import (chezscheme))
-(compile-program "bin/pisol.ss" "build/runtime/pisol.so")
-
