Normalize tracefs filesystem events
ober
bd236aaae7af9b2299050cbaadf981add622569f
--- a/docs/limits-followup.md +++ b/docs/limits-followup.md @@ -6,13 +6,13 @@ Status updated: 2026-05-21 (post child-status handshake phase) This document is a follow-up to `docs/limits.md` after reviewing the new limits/sandbox/audit module set added around commit `97eea41`. -The short version after the child-status phase: the new modules are wired far -enough for callers to choose safe fail-closed behavior based on actual -pre-exec child setup status. The focused primitive tests are part of -`make test`. Some backend work remains: Linux cgroup enforcement is not -implemented, tracefs is still a strace wrapper/parser rather than a full -normalized filesystem-event backend, and deeper backend-specific filesystem -and network denial tests are still needed. +The short version after the child-status and tracefs-normalization phases: the +new modules are wired far enough for callers to choose safe fail-closed +behavior based on actual pre-exec child setup status. The focused primitive +tests are part of `make test`. Some backend work remains: Linux cgroup +enforcement is not implemented, tracefs still lacks fd/cwd state tracking and +native backends, and deeper backend-specific filesystem and network denial +tests are still needed. ## Status After Follow-Up Fixes @@ -22,7 +22,7 @@ and network denial tests are still needed. | 2 | Process supervision | DONE — timeout/capture handling, `128 + signal` statuses, output caps, and pre-exec go/no-go handshakes are covered by focused tests | | 3 | Resource limits | SAFE PARTIAL — requested-limit plans and child install reports are per-kind; `require: '(limits)` fails closed before exec; parent-side time/output markers exist; **GAP**: cgroup v2 | | 4 | Executable identity | DONE — path search, realpath/stat identity, comparison helper, and TOCTOU caveat are present | -| 5 | Filesystem tracing | SAFE PARTIAL — `tracefs-capabilities` + fail-closed wrapper exist; **GAP**: fd/cwd tracking and normalized fs-event output | +| 5 | Filesystem tracing | SAFE PARTIAL — `tracefs-capabilities`, fail-closed wrapper, normalized `fs-event` output, and generic read/write/exec suggestions exist; **GAP**: fd/cwd tracking and native backends | | 6 | Network allowlist | DONE for decision layer — IP literals and localnet ranges are denied before wildcard matching; **GAP**: DNS recheck + child network sandbox/proxy handoff | | 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 | @@ -260,6 +260,10 @@ Implemented: - Linux `strace` command builder when `strace` exists. - parser for a subset of `strace -f -e trace=file,desc` lines. - summary by syscall/path. +- normalized `fs-event` records with operation classes such as `read`, `write`, + `create`, `delete`, `rename`, `metadata`, `readlink`, `symlink`, and `exec`. +- generic policy suggestion grouping as `((read . paths) (write . paths) + (exec . paths))`, reusable by `jsh` or other callers. Missing relative to `docs/limits.md`: @@ -269,9 +273,6 @@ Missing relative to `docs/limits.md`: - The parser does not maintain enough process state for full path resolution: cwd per process, fd table, fd inheritance, openat directory fd mappings, and exec identity changes are still missing. -- Events do not use the richer `fs-event` shape from the design document. They - record syscall and one path, not normalized operation classes such as read, - write, create, delete, rename, metadata, directory listing, symlink, or exec. - `tracefs-strace-cmd` silently returns the raw target command when tracing is unavailable. That can look like success unless the caller separately checks `tracefs-mode`. @@ -281,9 +282,10 @@ Required next work: 1. Add an explicit `tracefs-capabilities` report. 2. Make unavailable tracing impossible to confuse with successful empty traces. 3. Track cwd and fd state for Linux `strace`. -4. Normalize events into the design's `fs-event` format. -5. Add tests for open, stat, unlink, rename, exec, relative paths, openat, and - forked children. +4. DONE — normalize events into the design's `fs-event` format. +5. Add tests for stat, rename, relative paths, openat directory-fd state, and + forked children. Basic open/create/unlink/exec normalization and policy + suggestions are covered by focused primitive tests. ## 6. Network Allowlist Proxy --- a/lib/std/os/tracefs.ss +++ b/lib/std/os/tracefs.ss @@ -38,8 +38,12 @@ tracefs-wrap-command tracefs-parse-strace tracefs-parse-strace-file + tracefs-parse-normalized-strace-file + tracefs-normalize-events + trace-event->fs-events tracefs-events-by-path tracefs-events-summary + tracefs-policy-suggestions trace-event? make-trace-event @@ -49,7 +53,20 @@ trace-event-args trace-event-result trace-event-errno - trace-event-path) + trace-event-path + + fs-event? + make-fs-event + fs-event-pid + fs-event-ppid + fs-event-exe + fs-event-op + fs-event-path + fs-event-cwd + fs-event-fd + fs-event-result + fs-event-errno + fs-event-timestamp-ms) (import (chezscheme) (only (jerboa core) def defstruct try catch finally) @@ -70,12 +87,26 @@ (def trace-event-errno trace-event-rec-errno) (def trace-event-path trace-event-rec-path) + (defstruct fs-event-rec + (pid ppid exe op path cwd fd result errno timestamp-ms)) + + (def fs-event? fs-event-rec?) + (def make-fs-event make-fs-event-rec) + (def fs-event-pid fs-event-rec-pid) + (def fs-event-ppid fs-event-rec-ppid) + (def fs-event-exe fs-event-rec-exe) + (def fs-event-op fs-event-rec-op) + (def fs-event-path fs-event-rec-path) + (def fs-event-cwd fs-event-rec-cwd) + (def fs-event-fd fs-event-rec-fd) + (def fs-event-result fs-event-rec-result) + (def fs-event-errno fs-event-rec-errno) + (def fs-event-timestamp-ms fs-event-rec-timestamp-ms) + ;; ---------- Mode/support ---------- (def (tracefs-supported?) - (case (tracefs-mode) - [(strace) #t] - [else #f])) + (eq? (tracefs-mode) 'strace)) (def (tracefs-mode) (cond @@ -98,7 +129,7 @@ ;; events as a complete syscall log. (let* ([mode (tracefs-mode)] [installed? (eq? mode 'strace)] - [backend (case mode [(strace) 'strace] [else 'none])]) + [backend (if (eq? mode 'strace) 'strace 'none)]) `((backend . ,backend) (status . ,(if installed? 'installed 'unavailable)) (platform . ,(platform-name)) @@ -208,6 +239,9 @@ (lambda () (tracefs-parse-strace port)) (lambda () (close-port port))))])) + (def (tracefs-parse-normalized-strace-file path) + (tracefs-normalize-events (tracefs-parse-strace-file path))) + (def (tracefs-parse-strace port) ;; Returns a list of trace-event records in input order. (let lp ([out '()]) @@ -486,6 +520,265 @@ (char=? (string-ref s i) #\()) (string->symbol (substring s 0 i))] [else (lp (+ i 1))])))) + ;; ---------- Normalized fs-event stream ---------- + + (def (arg-contains? args needle) + (let lp ([xs args]) + (cond + [(null? xs) #f] + [(and (string? (car xs)) + (substring-contains? (car xs) needle)) #t] + [else (lp (cdr xs))]))) + + (def (tracefs-open-create? args) + (or (arg-contains? args "O_CREAT") + (arg-contains? args "O_TMPFILE"))) + + (def (tracefs-open-write? args) + (or (arg-contains? args "O_WRONLY") + (arg-contains? args "O_RDWR") + (arg-contains? args "O_APPEND") + (arg-contains? args "O_TRUNC"))) + + (def (tracefs-open-read? args) + (cond + [(arg-contains? args "O_PATH") #f] + [(arg-contains? args "O_WRONLY") (arg-contains? args "O_RDWR")] + [else #t])) + + (def (tracefs-classify-ops syscall args) + (cond + [(or (string=? syscall "open") + (string=? syscall "openat") + (string=? syscall "openat2")) + (let ([ops '()]) + (when (tracefs-open-read? args) + (set! ops (cons 'read ops))) + (when (tracefs-open-write? args) + (set! ops (cons 'write ops))) + (when (tracefs-open-create? args) + (set! ops (cons 'create ops))) + (if (null? ops) '(read) (reverse ops)))] + [(string=? syscall "creat") '(create write)] + [(or (string=? syscall "execve") + (string=? syscall "execveat")) + '(exec)] + [(or (string=? syscall "unlink") + (string=? syscall "unlinkat") + (string=? syscall "rmdir")) + '(delete)] + [(or (string=? syscall "rename") + (string=? syscall "renameat") + (string=? syscall "renameat2")) + '(rename)] + [(or (string=? syscall "mkdir") + (string=? syscall "mkdirat") + (string=? syscall "mknod") + (string=? syscall "mknodat")) + '(create)] + [(or (string=? syscall "symlink") + (string=? syscall "symlinkat") + (string=? syscall "link") + (string=? syscall "linkat")) + '(symlink)] + [(or (string=? syscall "readlink") + (string=? syscall "readlinkat")) + '(readlink)] + [(or (string=? syscall "getdents") + (string=? syscall "getdents64")) + '(readdir)] + [(or (string=? syscall "truncate") + (string=? syscall "ftruncate") + (string=? syscall "chmod") + (string=? syscall "fchmod") + (string=? syscall "fchmodat") + (string=? syscall "chown") + (string=? syscall "lchown") + (string=? syscall "fchownat") + (string=? syscall "utime") + (string=? syscall "utimes") + (string=? syscall "utimensat") + (string=? syscall "setxattr") + (string=? syscall "lsetxattr") + (string=? syscall "removexattr") + (string=? syscall "lremovexattr")) + '(write)] + [(or (string=? syscall "stat") + (string=? syscall "lstat") + (string=? syscall "fstatat") + (string=? syscall "newfstatat") + (string=? syscall "statx") + (string=? syscall "access") + (string=? syscall "faccessat") + (string=? syscall "faccessat2") + (string=? syscall "getxattr") + (string=? syscall "lgetxattr") + (string=? syscall "listxattr") + (string=? syscall "llistxattr")) + '(metadata)] + [else '()])) + + (def (list-ref/default xs idx default) + (let lp ([rest xs] [i idx]) + (cond + [(null? rest) default] + [(= i 0) (car rest)] + [else (lp (cdr rest) (- i 1))]))) + + (def (tracefs-path-arg-indexes syscall) + (cond + [(or (string=? syscall "openat") + (string=? syscall "openat2") + (string=? syscall "fstatat") + (string=? syscall "newfstatat") + (string=? syscall "faccessat") + (string=? syscall "faccessat2") + (string=? syscall "unlinkat") + (string=? syscall "mkdirat") + (string=? syscall "mknodat") + (string=? syscall "readlinkat") + (string=? syscall "fchmodat") + (string=? syscall "fchownat") + (string=? syscall "utimensat") + (string=? syscall "execveat")) + '(1)] + [(or (string=? syscall "renameat") + (string=? syscall "renameat2") + (string=? syscall "linkat")) + '(1 3)] + [(string=? syscall "symlinkat") '(2)] + [(or (string=? syscall "rename") + (string=? syscall "link")) + '(0 1)] + [(string=? syscall "symlink") '(1)] + [else '(0)])) + + (def (tracefs-arg->path raw) + (let ([unq (unquote-arg raw)]) + (cond + [(not unq) #f] + [(and raw + (> (string-length raw) 0) + (char=? (string-ref raw 0) #\")) unq] + [(and (> (string-length unq) 0) + (char=? (string-ref unq 0) #\/)) unq] + [else #f]))) + + (def (tracefs-event-paths syscall args fallback) + (let lp ([idxs (tracefs-path-arg-indexes syscall)] [out '()]) + (cond + [(null? idxs) + (let ([paths (reverse out)]) + (cond + [(pair? paths) paths] + [fallback (list fallback)] + [else '()]))] + [else + (let ([p (tracefs-arg->path + (list-ref/default args (car idxs) #f))]) + (lp (cdr idxs) + (if p (cons p out) out)))]))) + + (def (tracefs-success? e) + (let ([rc (trace-event-result e)]) + (and (not (trace-event-errno e)) + (or (not rc) (and (integer? rc) (>= rc 0)))))) + + (def (tracefs-result-symbol e) + (if (tracefs-success? e) 'ok 'error)) + + (def (tracefs-fd-result e) + (let ([sc (trace-event-syscall e)] + [rc (trace-event-result e)]) + (and (integer? rc) + (>= rc 0) + (or (string=? sc "open") + (string=? sc "openat") + (string=? sc "openat2") + (string=? sc "creat")) + rc))) + + (def (make-fs-event-from-trace e op path) + (make-fs-event-rec + (trace-event-pid e) + #f + #f + op + path + #f + (tracefs-fd-result e) + (tracefs-result-symbol e) + (trace-event-errno e) + (trace-event-ts e))) + + (def (trace-event->fs-events e) + (let* ([syscall (trace-event-syscall e)] + [args (trace-event-args e)] + [ops (tracefs-classify-ops syscall args)] + [paths (tracefs-event-paths syscall args (trace-event-path e))]) + (cond + [(or (null? ops) (null? paths)) '()] + [else + (let lp-path ([ps paths] [out '()]) + (cond + [(null? ps) (reverse out)] + [else + (let lp-op ([os ops] [out2 out]) + (cond + [(null? os) (lp-path (cdr ps) out2)] + [else + (lp-op (cdr os) + (cons (make-fs-event-from-trace e (car os) (car ps)) + out2))]))]))]))) + + (def (tracefs-normalize-events events) + (let lp ([xs events] [out '()]) + (cond + [(null? xs) (reverse out)] + [(fs-event? (car xs)) + (lp (cdr xs) (cons (car xs) out))] + [(trace-event? (car xs)) + (let add ([ys (trace-event->fs-events (car xs))] [acc out]) + (cond + [(null? ys) (lp (cdr xs) acc)] + [else (add (cdr ys) (cons (car ys) acc))]))] + [else (lp (cdr xs) out)]))) + + (def (unique-sorted-strings xs) + (let lp ([rest xs] [seen '()] [out '()]) + (cond + [(null? rest) + (list-sort string<? (reverse out))] + [(member (car rest) seen) + (lp (cdr rest) seen out)] + [else + (lp (cdr rest) + (cons (car rest) seen) + (cons (car rest) out))]))) + + (def (tracefs-policy-suggestions events) + ;; Returns ((read . paths) (write . paths) (exec . paths)). The input + ;; may be raw trace-event records or already-normalized fs-event records. + (let ([reads '()] [writes '()] [execs '()]) + (for-each + (lambda (e) + (when (and (fs-event? e) + (eq? (fs-event-result e) 'ok) + (string? (fs-event-path e))) + (let ([op (fs-event-op e)]) + (cond + [(memq op '(read metadata readdir readlink)) + (set! reads (cons (fs-event-path e) reads))] + [(memq op '(write create delete rename symlink)) + (set! writes (cons (fs-event-path e) writes))] + [(eq? op 'exec) + (set! execs (cons (fs-event-path e) execs))] + [else (void)])))) + (tracefs-normalize-events events)) + `((read . ,(unique-sorted-strings reads)) + (write . ,(unique-sorted-strings writes)) + (exec . ,(unique-sorted-strings execs))))) + ;; ---------- Summaries ---------- (def (tracefs-events-by-path events) --- a/tests/test-limits-primitives.ss +++ b/tests/test-limits-primitives.ss @@ -381,6 +381,70 @@ (and (eq? (cdr kv) 'refused) (not (car kv))))))) +(define (has-fs-event? events op path) + (let lp ([xs events]) + (cond + [(null? xs) #f] + [(and (fs-event? (car xs)) + (eq? (fs-event-op (car xs)) op) + (equal? (fs-event-path (car xs)) path)) + #t] + [else (lp (cdr xs))]))) + +(define (has-path? xs path) + (let lp ([rest xs]) + (cond + [(null? rest) #f] + [(equal? (car rest) path) #t] + [else (lp (cdr rest))]))) + +(let* ([raw (tracefs-parse-strace + (open-input-string + (string-append + "123 openat(AT_FDCWD, \"/repo/package.json\", O_RDONLY|O_CLOEXEC) = 3\n" + "123 openat(AT_FDCWD, \"/repo/out.txt\", O_WRONLY|O_CREAT|O_TRUNC, 0666) = 4\n" + "123 execve(\"/usr/bin/node\", [\"node\"], 0x7ffe) = 0\n" + "123 unlink(\"/repo/old.txt\") = 0\n" + "123 access(\"/repo/missing\", F_OK) = -1 ENOENT (No such file or directory)\n")))] + [events (tracefs-normalize-events raw)] + [suggest (tracefs-policy-suggestions events)]) + (test-pred "tracefs-normalize-events emits read fs-event" + events + (lambda (xs) (has-fs-event? xs 'read "/repo/package.json"))) + (test-pred "tracefs-normalize-events emits create fs-event" + events + (lambda (xs) (has-fs-event? xs 'create "/repo/out.txt"))) + (test-pred "tracefs-normalize-events emits write fs-event" + events + (lambda (xs) (has-fs-event? xs 'write "/repo/out.txt"))) + (test-pred "tracefs-normalize-events emits exec fs-event" + events + (lambda (xs) (has-fs-event? xs 'exec "/usr/bin/node"))) + (test-pred "tracefs-normalize-events marks errno as error" + events + (lambda (xs) + (let lp ([rest xs]) + (cond + [(null? rest) #f] + [(and (equal? (fs-event-path (car rest)) "/repo/missing") + (eq? (fs-event-result (car rest)) 'error) + (eq? (fs-event-errno (car rest)) 'ENOENT)) + #t] + [else (lp (cdr rest))])))) + (test-pred "tracefs-policy-suggestions includes read path" + (cdr (assq 'read suggest)) + (lambda (xs) (has-path? xs "/repo/package.json"))) + (test-pred "tracefs-policy-suggestions includes write path" + (cdr (assq 'write suggest)) + (lambda (xs) (and (has-path? xs "/repo/out.txt") + (has-path? xs "/repo/old.txt")))) + (test-pred "tracefs-policy-suggestions includes exec path" + (cdr (assq 'exec suggest)) + (lambda (xs) (has-path? xs "/usr/bin/node"))) + (test-pred "tracefs-policy-suggestions skips failed access path" + (cdr (assq 'read suggest)) + (lambda (xs) (not (has-path? xs "/repo/missing"))))) + ;; ===== temp-home: sandbox integration ===== (printf "[temp-home]~%")