Add reusable path capability resolver
ober
0010d15b7aeddca8a3335298b9a320419847a121
--- a/docs/limits-followup.md +++ b/docs/limits-followup.md @@ -1,7 +1,7 @@ # Limits Follow-Up: Missing Enforcement and Test Work Reviewed: 2026-05-21 -Status updated: 2026-05-22 (allow-proxy DNS/recheck phase) +Status updated: 2026-05-22 (path capability resolver phase) This document is a follow-up to `docs/limits.md` after reviewing the new limits/sandbox/audit module set added around commit `97eea41`. @@ -24,7 +24,7 @@ backend-specific filesystem and network denial tests are still needed. | 5 | Filesystem tracing | SAFE PARTIAL — `tracefs-capabilities`, fail-closed wrapper, normalized `fs-event` output, best-effort fd/cwd tracking, and generic read/write/exec suggestions exist; **GAP**: native backends and deeper Linux traced-run tests | | 6 | Network allowlist | SAFE PARTIAL — reusable decision layer, parent-side DNS resolution, resolved-address localnet recheck, structured proxy events, and binary CONNECT tunneling exist; **GAP**: child network sandbox/proxy handoff and direct-network denial tests | | 7 | Environment/secrets | DONE — default deny policy, argv validation, env construction, and redaction helpers exist | -| 8 | Temp HOME/cache | DONE for helper layer — fake HOME, scratch/cache grants, env overrides, cleanup, and sandbox grant helper exist | +| 8 | Temp HOME/cache | DONE for helper layer — fake HOME, scratch/cache grants, env overrides, cleanup, sandbox grant helper, and reusable named path capability resolution exist | | 9 | Structured audit model | PARTIAL — event constructors and redaction exist; **GAP**: full integration from all primitives | | 10 | Tests | DONE — `tests/test-limits-primitives.ss` covers the new primitive set and is wired into `make test` | @@ -41,6 +41,7 @@ New Jerboa modules exist for the main proposed primitives: - `(std os supervise)` - `(std os exec-id)` - `(std os tracefs)` +- `(std os path-caps)` - `(std net allowlist)` - `(std net allow-proxy)` - `(std security env)` @@ -464,6 +465,8 @@ Current coverage: - `allow-proxy-connect-decision` DNS resolution and resolved-localnet denial. - `env-policy-build` strips denied vars and injects explicit secrets. - `temp-home` cleanup and env overrides. +- `path-caps` named directory capabilities, memoized temp resolution, and + unresolved-capability reporting. - `audit-log` redaction and JSONL validity. ## Suggested Implementation Order new file mode 100644 --- /dev/null +++ b/lib/std/os/path-caps.ss @@ -0,0 +1,214 @@ +#!chezscheme +;;; (std os path-caps) -- Reusable named directory capability resolver +;;; +;;; Resolves symbolic path capabilities used by launchers and sandbox wrappers: +;;; @project +;;; @scratch +;;; @cache:<name> +;;; @config:<name> +;;; @home +;;; @transaction-workspace +;;; +;;; Callers can supply make-temp: and workspace: callbacks to keep lifecycle +;;; and app-specific workspace semantics outside this reusable resolver. + +(library (std os path-caps) + (export + path-capability? + path-capability-parts + make-path-capability-resolver + path-capability-resolver? + path-capability-resolver-temp-dirs + path-capability-resolver-clear! + path-capability-resolve + path-capability-resolve-paths + find-repo-root) + + (import (chezscheme) + (only (jerboa core) def defstruct try catch) + (only (std os temp) make-temporary-directory)) + + (defstruct path-capability-resolver-rec + (cache temp-dirs make-temp workspace project-root home temp-prefix temp-root)) + + (def path-capability-resolver? path-capability-resolver-rec?) + (def path-capability-resolver-temp-dirs + path-capability-resolver-rec-temp-dirs) + + (def (path-capability? s) + (and (string? s) + (> (string-length s) 0) + (char=? (string-ref s 0) #\@))) + + (def (string-index-char s ch) + (let loop ([i 0]) + (cond + [(= i (string-length s)) #f] + [(char=? (string-ref s i) ch) i] + [else (loop (+ i 1))]))) + + (def (path-capability-parts cap) + (let* ([body (substring cap 1 (string-length cap))] + [colon (string-index-char body #\:)]) + (cond + [colon (values (substring body 0 colon) + (substring body (+ colon 1) (string-length body)))] + [else (values body "")]))) + + (def (option opts key default) + (let lp ([xs opts]) + (cond + [(null? xs) default] + [(null? (cdr xs)) + (error 'make-path-capability-resolver + "odd number of options at" (car xs))] + [(eq? (car xs) key) (cadr xs)] + [else (lp (cddr xs))]))) + + (def (make-path-capability-resolver . opts) + (make-path-capability-resolver-rec + '() + '() + (option opts 'make-temp: #f) + (option opts 'workspace: #f) + (option opts 'project-root: #f) + (option opts 'home: (getenv "HOME")) + (option opts 'temp-prefix: "jerboa-cap-") + (option opts 'temp-root: (or (getenv "TMPDIR") "/tmp")))) + + (def (path-capability-resolver-clear! r) + (path-capability-resolver-rec-cache-set! r '()) + (path-capability-resolver-rec-temp-dirs-set! r '())) + + (def (join dir name) + (let ([n (string-length dir)]) + (cond + [(= n 0) name] + [(char=? (string-ref dir (- n 1)) #\/) (string-append dir name)] + [else (string-append dir "/" name)]))) + + (def (safe-name-char? ch) + (or (char<=? #\a ch #\z) + (char<=? #\A ch #\Z) + (char<=? #\0 ch #\9) + (char=? ch #\.) + (char=? ch #\_) + (char=? ch #\-))) + + (def (sanitize-name s) + (let ([out (make-string (string-length s) #\_)]) + (let lp ([i 0]) + (cond + [(= i (string-length s)) out] + [else + (string-set! out i + (let ([ch (string-ref s i)]) + (if (safe-name-char? ch) ch #\_))) + (lp (+ i 1))])))) + + (def (default-make-temp r tag) + (let* ([safe (sanitize-name tag)] + [tmpl (join (path-capability-resolver-rec-temp-root r) + (string-append + (path-capability-resolver-rec-temp-prefix r) + safe + "-XXXXXX"))] + [path (make-temporary-directory tmpl)]) + (path-capability-resolver-rec-temp-dirs-set! + r + (cons path (path-capability-resolver-rec-temp-dirs r))) + path)) + + (def (resolver-make-temp r tag) + (let ([mk (path-capability-resolver-rec-make-temp r)]) + (if mk + (mk (sanitize-name tag)) + (default-make-temp r tag)))) + + (def (resolve-workspace r) + (let ([w (path-capability-resolver-rec-workspace r)]) + (cond + [(procedure? w) (w)] + [else w]))) + + (def (parent-dir-of path) + (let ([n (string-length path)]) + (cond + [(= n 0) #f] + [else + (let loop ([i (- n 1)]) + (cond + [(< i 0) #f] + [(char=? (string-ref path i) #\/) + (cond + [(= i 0) "/"] + [else (substring path 0 i)])] + [else (loop (- i 1))]))]))) + + (def (find-repo-root cwd) + (let loop ([dir cwd]) + (cond + [(or (not dir) (= 0 (string-length dir))) #f] + [(file-exists? (join dir ".git")) dir] + [(string=? dir "/") #f] + [else + (let ([up (parent-dir-of dir)]) + (and up (not (string=? up dir)) (loop up)))]))) + + (def (current-directory/fallback) + (or (try (current-directory) (catch (e) #f)) + (getenv "PWD"))) + + (def (cache-ref r cap) + (cond + [(assoc cap (path-capability-resolver-rec-cache r)) => cdr] + [else #f])) + + (def (cache-set! r cap path) + (path-capability-resolver-rec-cache-set! + r + (cons (cons cap path) (path-capability-resolver-rec-cache r)))) + + (def (resolve-uncached r cap) + (call-with-values + (lambda () (path-capability-parts cap)) + (lambda (name arg) + (cond + [(string=? name "project") + (or (path-capability-resolver-rec-project-root r) + (let ([cwd (current-directory/fallback)]) + (and cwd (or (find-repo-root cwd) cwd))))] + [(string=? name "scratch") + (resolver-make-temp r "scratch")] + [(and (string=? name "cache") (> (string-length arg) 0)) + (resolver-make-temp r (string-append "cache-" arg))] + [(and (string=? name "config") (> (string-length arg) 0)) + (resolver-make-temp r (string-append "config-" arg))] + [(string=? name "home") + (path-capability-resolver-rec-home r)] + [(string=? name "transaction-workspace") + (resolve-workspace r)] + [else #f])))) + + (def (path-capability-resolve r cap) + (cond + [(not (path-capability? cap)) #f] + [(cache-ref r cap) => (lambda (p) p)] + [else + (let ([resolved (resolve-uncached r cap)]) + (when resolved (cache-set! r cap resolved)) + resolved)])) + + (def (path-capability-resolve-paths r xs) + (let lp ([xs xs] [resolved '()] [unresolved '()]) + (cond + [(null? xs) + (values (reverse resolved) (reverse unresolved))] + [(path-capability? (car xs)) + (let ([p (path-capability-resolve r (car xs))]) + (cond + [p (lp (cdr xs) (cons p resolved) unresolved)] + [else (lp (cdr xs) resolved + (cons (cons (car xs) #f) unresolved))]))] + [else + (lp (cdr xs) (cons (car xs) resolved) unresolved)])))) --- a/tests/test-limits-primitives.ss +++ b/tests/test-limits-primitives.ss @@ -6,6 +6,7 @@ ;;; (std os limits) — per-launch install report shape ;;; (std os limits sandbox) — fail-closed gating, dynamic report ;;; (std os exec-id) — resolution, comparison helpers +;;; (std os path-caps) — reusable @path capability resolution ;;; (std net allowlist) — decision-only host allowlist checks ;;; (std net allow-proxy) — IP/localnet denial, structured events ;;; (std security env) — default deny patterns, validate-command @@ -21,6 +22,7 @@ (std os exec-id) (std os tracefs) (std os temp-home) + (std os path-caps) (std net allowlist) (std net allow-proxy) (std security env) @@ -217,6 +219,53 @@ (exec-id-resolve "/no/such/binary/xyzzy") #f) +;; ===== path-caps ===== +(printf "[path-caps]~%") + +(let ([r (make-path-capability-resolver + 'project-root: "/repo/project" + 'home: "/home/tester" + 'workspace: (lambda () "/tmp/workspace") + 'make-temp: (lambda (tag) (string-append "/tmp/cap-" tag)))]) + (test "path-capability? detects @name" + (path-capability? "@scratch") + #t) + (test "path-capability? rejects literal path" + (path-capability? "/tmp") + #f) + (test "path-caps resolves @project" + (path-capability-resolve r "@project") + "/repo/project") + (test "path-caps resolves @home" + (path-capability-resolve r "@home") + "/home/tester") + (test "path-caps resolves @transaction-workspace" + (path-capability-resolve r "@transaction-workspace") + "/tmp/workspace") + (test "path-caps resolves @cache:name with safe tag" + (path-capability-resolve r "@cache:npm") + "/tmp/cap-cache-npm") + (test "path-caps sanitizes generated temp tags" + (path-capability-resolve r "@cache:../evil") + "/tmp/cap-cache-.._evil") + (let ([a (path-capability-resolve r "@scratch")] + [b (path-capability-resolve r "@scratch")]) + (test "path-caps memoizes temp capability" + (equal? a b) + #t)) + (call-with-values + (lambda () + (path-capability-resolve-paths + r + '("@scratch" "/etc/hosts" "@nope"))) + (lambda (paths unresolved) + (test "path-caps resolve-paths returns paths" + paths + '("/tmp/cap-scratch" "/etc/hosts")) + (test "path-caps resolve-paths returns unresolved caps" + unresolved + '(("@nope" . #f)))))) + ;; ===== allow-proxy: IP/localnet denial ===== (printf "[allow-proxy]~%")