Commit3bd82336Recorded15 Jul 2026Repositorysigil-system
S0 skeleton: (sigil system) capability library with grant-checked fs, exec, and PTY sessions
Message
The S0 core of the system-access program: a generic, grant-checked capability library over the local system, consumed the same way in-process and (later) by a remote node.
Modules (src/sigil/system/): - grant: deny-by-default policy engine. fs ro/rw path allowlists (realpath-canonicalized, component-safe prefix match so /a/b does not cover /a/bc; write targets canonicalize the parent so a symlinked parent cannot escape), exec allowlist matched EXACTLY against argv[0] (a basename match would let /tmp/evil/git satisfy an "git" grant), exec:full, pty flag, and an in-memory decision audit log whose record shape is what a durable log will persist. - fs: thin grant-checked wrappers over native (sigil fs) — read-dir (one stat dict per entry), stat, read-file(/-bytes), atomic tmp+rename write, mkdir, rename, delete (recursive opt-in, does not follow symlinks out of the tree). - process: grant-checked one-shot exec (argv list, never a shell string). stdout and stderr are always drained concurrently under a scheduler, so a stderr-heavy child cannot deadlock on a full pipe buffer; the join completes even if a reader raises; the child is reaped without blocking the VM. - session: the Session plane. session-open spawns a PTY child plus a reader-pump (credit-window flow control: the pump stops reading the master when the window is exhausted, so backpressure reaches a flooding child through the kernel pty buffer with no buffering growth in our stack) and a writer-drain (enqueue-and-drain, partial-write re-slice). Teardown is ordered so the pty master is never closed out from under a goroutine parked on its fd (a select on a closed fd never reports ready): the master is the reader-pump's sole property, closed only after the child is reaped. session-write/resize/signal/ close/credit; session-events is a channel of data events then one exit event. - proof: the headless S0 proof as a runnable entry module.
Fork discipline for the PTY lives entirely in the monorepo's (sigil process) C layer; nothing here forks. Builds against a patched sigil via dev-redirects.sgl until the (sigil process) pty primitives ship in a release.
Proof + tests (sigil test --redirects dev-redirects.sgl): 24/24 green, including the exit criterion (open a pty, run ls, stream output, resize, reap) plus a stdin round-trip, a close-kills-a-sleeper case, and a stderr-heavy no-deadlock regression. sigil run --redirects dev-redirects.sgl runs the standalone headless proof.
Changed
.gitignore | 3 ++
dev-redirects.sgl | 11 +++++
package.sgl | 36 ++++++++++++++
sigil.lock | 41 ++++++++++++++++
src/sigil/system/fs.sgl | 147 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/sigil/system/grant.sgl | 256 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/sigil/system/process.sgl | 120 ++++++++++++++++++++++++++++++++++++++++++++++
src/sigil/system/proof.sgl | 66 ++++++++++++++++++++++++++
src/sigil/system/session.sgl | 426 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
test/test-system.sgl | 261 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
10 files changed, 1367 insertions(+)Diff
.gitignoreadded
@@ -0,0 +1,3 @@
+1
build/+2
.sigil/+3
*.logdev-redirects.sgladded
@@ -0,0 +1,11 @@
+1
;; Development redirects — point dependencies at a local Sigil checkout+2
;; when developing against unreleased runtime changes (e.g. the pty-aware+3
;; spawn primitives in (sigil process)).+4
;;+5
;; Usage: sigil build --redirects dev-redirects.sgl+6
;; Adjust dir: if your sigil checkout lives elsewhere.+7
(redirects+8
repos: (list+9
(for-repo+10
url: "codeberg:sigil/sigil"+11
use: (from-path dir: "../sigil"))))package.sgladded
@@ -0,0 +1,36 @@
+1
;;; sigil-system - System capability library for Sigil+2
;;;+3
;;; Grant-checked access to the local system: filesystem operations,+4
;;; one-shot process execution, and PTY-backed stream sessions. One+5
;;; shared implementation consumed both in-process (desktop embedding)+6
;;; and by remote-node wrappers.+7
+8
(package+9
name: "sigil-system"+10
version: "0.1.0"+11
sigil: "^0.17"+12
description: "System capability library: filesystem, processes, and PTY sessions behind a grant-checked surface"+13
url: "https://codeberg.org/sigil/sigil-system"+14
license: "BSD-3-Clause"+15
authors: (list "David Wilson <[email protected]>")+16
+17
;; The headless PTY proof (the S0 exit criterion) is the default+18
;; runnable: `sigil run --redirects dev-redirects.sgl` demonstrates+19
;; open -> stream ls -> resize -> reap end to end. `sigil run`'s dev+20
;; loader imports this entry value as a module and calls its `main`,+21
;; so the entry is the module name alone (not the `(module main)`+22
;; form used by native-bundled apps).+23
entry: '(sigil system proof)+24
bundle-name: "headless-pty-proof"+25
+26
configs: (list+27
(config+28
name: 'dev+29
output-dir: "build/dev"+30
debug?: #t+31
optimize: 0+32
bundle?: #t))+33
+34
dev-dependencies: (list+35
(from-git url: "codeberg:sigil/sigil" package: "sigil-test" version: "^0.17")+36
(from-git url: "codeberg:sigil/sigil" package: "sigil-test-runner" version: "^0.17")))sigil.lockadded
@@ -0,0 +1,41 @@
+1
;; Auto-generated by sigil deps install. Do not edit.+2
(lock+3
(package name: "sigil-stdlib"+4
url: "codeberg:sigil/sigil"+5
ref: "^0.17"+6
sha: "8b3e7f90795b569a5ac3011c5a46311989230648"+7
package-selector: "sigil-stdlib"+8
version: "0.17.13")+9
(package name: "sigil-test"+10
url: "codeberg:sigil/sigil"+11
ref: "^0.17"+12
sha: "8b3e7f90795b569a5ac3011c5a46311989230648"+13
package-selector: "sigil-test"+14
version: "0.17.13")+15
(package name: "sigil-test-runner"+16
url: "codeberg:sigil/sigil"+17
ref: "^0.17"+18
sha: "8b3e7f90795b569a5ac3011c5a46311989230648"+19
package-selector: "sigil-test-runner"+20
version: "0.17.13")+21
(package name: "sigil-ansi"+22
url: "codeberg:sigil/sigil-ansi"+23
ref: "^0.16.0"+24
sha: "1e14b6f9d034ca8ef9f404e2ded316d0780ad7cf"+25
version: "0.16.0")+26
(package name: "sigil-json"+27
url: "codeberg:sigil/sigil-json"+28
ref: "^0.16.0"+29
sha: "55c9e74712b5f79b45d41c65cfe0aef2c8f7e155"+30
version: "0.16.0")+31
(package name: "sigil-version"+32
url: "codeberg:sigil/sigil-version"+33
ref: "^0.16.0"+34
sha: "2d2c9ef9c2694466f65abc14cddf9bfb9cada4a4"+35
version: "0.16.0")+36
(package name: "sigil-git"+37
url: "codeberg:sigil/sigil-git"+38
ref: "^0.16.0"+39
sha: "2d54eb99d3ca0597b3ccd9d4829d312c54721086"+40
version: "0.16.1")+41
)src/sigil/system/fs.sgladded
@@ -0,0 +1,147 @@
+1
;;; (sigil system fs) - Grant-Checked Filesystem Capability+2
;;;+3
;;; The Resource-plane filesystem surface: thin capability wrappers over+4
;;; the native `(sigil fs)` operations, with a grant check at every entry+5
;;; point. Nothing here reimplements filesystem work — the value is the+6
;;; uniform, scoped surface that both an in-process embedding and a+7
;;; remote node wrapper call identically.+8
;;;+9
;;; Every operation takes a grants table (see `(sigil system grant)`)+10
;;; as its first argument and raises `grant-denied` when the principal+11
;;; lacks access to the (canonicalized) path.+12
;;;+13
;;; ```scheme+14
;;; (import (sigil system grant)+15
;;; (sigil system fs))+16
;;;+17
;;; (define g (make-grants))+18
;;; (grant-add! g "fs:rw:/tmp/work")+19
;;;+20
;;; (fs-write-file g "/tmp/work/hello.txt" "hi\n")+21
;;; (fs-read-file g "/tmp/work/hello.txt") ; => "hi\n"+22
;;; (fs-read-dir g "/tmp/work")+23
;;; ;; => (#{ name: "hello.txt" type: file size: 3 mtime: ... mode: ... })+24
;;; ```+25
+26
(define-library (sigil system fs)+27
(import (sigil fs)+28
(sigil path)+29
(sigil io)+30
(sigil system grant))+31
+32
(export+33
fs-read-dir+34
fs-stat+35
fs-read-file+36
fs-read-file-bytes+37
fs-write-file+38
fs-mkdir+39
fs-rename+40
fs-delete)+41
+42
(begin+43
+44
;; Build the rich stat dict all read surfaces share.+45
(define (stat->dict name path st)+46
(dict name: name+47
path: path+48
type: (stat-type st)+49
size: (stat-size st)+50
mtime: (stat-mtime st)+51
mode: (stat-mode st)))+52
+53
;;; Stat a file or directory. Returns a dict with `name:` `path:`+54
;;; `type:` `size:` `mtime:` `mode:`, or raises if the path does+55
;;; not exist.+56
(define (fs-stat g path)+57
(: any? string? -> dict?)+58
(grant-assert! g 'fs-read path)+59
(let ((st (file-stat path)))+60
(unless st+61
(error "fs-stat: no such path" path))+62
(stat->dict (path-basename path) path st)))+63
+64
;;; List a directory. Returns one stat dict per entry (the one+65
;;; round-trip a directory view needs). Entries that vanish between+66
;;; the listing and the stat are skipped.+67
(define (fs-read-dir g path)+68
(: any? string? -> list?)+69
(grant-assert! g 'fs-read path)+70
(let ((names (directory-list path)))+71
(unless names+72
(error "fs-read-dir: cannot list directory" path))+73
(fold-right+74
(lambda (name acc)+75
(let* ((entry-path (path-join path name))+76
(st (file-stat entry-path)))+77
(if st+78
(cons (stat->dict name entry-path st) acc)+79
acc)))+80
'()+81
names)))+82
+83
;;; Read a file's contents as a string.+84
(define (fs-read-file g path)+85
(: any? string? -> string?)+86
(grant-assert! g 'fs-read path)+87
(read-file-string path))+88
+89
;;; Read a file's contents as a bytevector.+90
(define (fs-read-file-bytes g path)+91
(: any? string? -> bytevector?)+92
(grant-assert! g 'fs-read path)+93
(read-file-bytes path))+94
+95
;;; Write a file atomically (write to a temporary sibling, then+96
;;; rename over the target). Content may be a string or bytevector.+97
;;; Returns the new stat dict.+98
(define (fs-write-file g path content)+99
(: any? string? any? -> dict?)+100
(grant-assert! g 'fs-write path)+101
(let ((tmp (string-append path ".sigil-system-tmp")))+102
(if (bytevector? content)+103
(write-file-bytes tmp content)+104
(write-file-string tmp content))+105
(rename-file tmp path)+106
(let ((st (file-stat path)))+107
(stat->dict (path-basename path) path st))))+108
+109
;;; Create a directory (including missing parents).+110
(define (fs-mkdir g path)+111
(: any? string? -> void?)+112
(grant-assert! g 'fs-write path)+113
(ensure-directory path))+114
+115
;;; Rename/move a file or directory. Both endpoints need write+116
;;; access (removing from the source, creating at the destination).+117
(define (fs-rename g from to)+118
(: any? string? string? -> void?)+119
(grant-assert! g 'fs-write from)+120
(grant-assert! g 'fs-write to)+121
(rename-file from to))+122
+123
;;; Delete a file, or a directory with `recursive: #t`. Deleting a+124
;;; non-empty directory without `recursive:` raises; recursion is+125
;;; never the default.+126
(define (fs-delete g path (keys: (recursive #f)))+127
(: any? string? (recursive: boolean?) -> void?)+128
(grant-assert! g 'fs-write path)+129
(cond+130
((not (directory? path))+131
(delete-file path))+132
(recursive+133
(delete-tree path))+134
(else+135
;; delete-directory raises on non-empty; that is the contract.+136
(delete-directory path))))+137
+138
;; Recursive delete helper: post-order walk.+139
(define (delete-tree path)+140
(for-each+141
(lambda (name)+142
(let ((entry (path-join path name)))+143
(if (and (directory? entry) (not (symlink? entry)))+144
(delete-tree entry)+145
(delete-file entry))))+146
(directory-list path))+147
(delete-directory path))))src/sigil/system/grant.sgladded
@@ -0,0 +1,256 @@
+1
;;; (sigil system grant) - Capability Grant Engine+2
;;;+3
;;; The deny-by-default scoping policy that guards every capability entry+4
;;; point in this library. A grants table declares what a principal may+5
;;; do; each (sigil system fs|process|session) operation checks the table+6
;;; before touching the system.+7
;;;+8
;;; The same engine serves two postures: an in-process desktop embedding+9
;;; typically runs `grant-allow-all` (it is the user's own application),+10
;;; while a remote node runs `make-grants` plus explicit grant entries+11
;;; (deny-by-default). Enforcement logic is identical in both.+12
;;;+13
;;; ## Grant specs+14
;;;+15
;;; Grants are added with compact spec strings (the same grammar a node+16
;;; CLI would accept):+17
;;;+18
;;; - `fs:ro:<path>` — read-only filesystem access under <path>+19
;;; - `fs:rw:<path>` — read-write filesystem access under <path>+20
;;; - `exec:allowlist:<cmd>,<cmd>` — allow executing these commands+21
;;; - `exec:full` — allow executing anything+22
;;; - `pty:on` — allow opening PTY sessions+23
;;;+24
;;; ```scheme+25
;;; (import (sigil system grant))+26
;;;+27
;;; (define g (make-grants principal: "worker-1"))+28
;;; (grant-add! g "fs:rw:/tmp/work")+29
;;; (grant-add! g "exec:allowlist:ls,git")+30
;;; (grant-add! g "pty:on")+31
;;;+32
;;; (grant-check g 'fs-read "/tmp/work/notes.txt") ; => #t+33
;;; (grant-check g 'fs-write "/etc/passwd") ; => #f+34
;;; (grant-assert! g 'exec "rm") ; raises+35
;;; ```+36
;;;+37
;;; Paths are canonicalized (symlinks resolved) before checking, so a+38
;;; symlink escaping an allowed root is denied. Every decision is+39
;;; recorded in an in-memory audit log (`grant-decisions`); a durable+40
;;; append-only log is a later refinement, but the decision record shape+41
;;; is already what that log will persist.+42
+43
(define-library (sigil system grant)+44
(import (sigil fs)+45
(sigil path)+46
(sigil string)+47
(sigil time))+48
+49
(export+50
;; Construction+51
make-grants+52
grant-allow-all+53
grants?+54
grants-principal+55
+56
;; Adding grants+57
grant-add!+58
+59
;; Checking+60
grant-check+61
grant-assert!+62
+63
;; Audit+64
grant-decisions)+65
+66
(begin+67
+68
;; Grants are a small mutable table:+69
;; (vector 'grants principal fs-entries exec pty decisions)+70
;; fs-entries: list of (mode . canonical-root), mode in {ro rw}+71
;; exec: 'off | 'full | list of allowed command names+72
;; pty: boolean+73
;; decisions: reverse-chronological list of decision dicts+74
+75
(define (make-grants-vector principal fs-entries exec pty)+76
(vector 'grants principal fs-entries exec pty '()))+77
+78
;;; Create an empty, deny-by-default grants table.+79
;;;+80
;;; ```scheme+81
;;; (define g (make-grants principal: "worker-1"))+82
;;; (grant-check g 'pty #f) ; => #f — nothing is allowed yet+83
;;; ```+84
(define (make-grants (keys: (principal "owner")))+85
(: (principal: string?) -> any?)+86
(make-grants-vector principal '() 'off #f))+87
+88
;;; Create a fully permissive grants table (the in-process owner+89
;;; posture: the embedding application is the user's own).+90
(define (grant-allow-all (keys: (principal "owner")))+91
(: (principal: string?) -> any?)+92
(make-grants-vector principal (list (cons 'rw "/")) 'full #t))+93
+94
;;; Check if a value is a grants table.+95
(define (grants? obj)+96
(: any? -> boolean?)+97
(and (vector? obj)+98
(> (vector-length obj) 0)+99
(eq? (vector-ref obj 0) 'grants)))+100
+101
;;; The principal this grants table scopes.+102
(define (grants-principal g)+103
(: any? -> string?)+104
(vector-ref g 1))+105
+106
(define (grants-fs-entries g) (vector-ref g 2))+107
(define (grants-exec g) (vector-ref g 3))+108
(define (grants-pty g) (vector-ref g 4))+109
(define (set-grants-fs-entries! g v) (vector-set! g 2 v))+110
(define (set-grants-exec! g v) (vector-set! g 3 v))+111
(define (set-grants-pty! g v) (vector-set! g 4 v))+112
+113
;;; The decision audit log, most recent first. Each entry is a dict:+114
;;; `#{ op: fs-read stream detail: "/path" allowed: #t at: <seconds> }`.+115
(define (grant-decisions g)+116
(: any? -> list?)+117
(vector-ref g 5))+118
+119
(define (record-decision! g op detail allowed)+120
(vector-set! g 5+121
(cons (dict op: op+122
detail: detail+123
allowed: allowed+124
at: (current-second))+125
(vector-ref g 5)))+126
allowed)+127
+128
;; ============================================================+129
;; Adding grants+130
;; ============================================================+131
+132
;;; Add a grant to the table from a spec string.+133
;;;+134
;;; Spec grammar: `fs:ro:<path>`, `fs:rw:<path>`,+135
;;; `exec:allowlist:<cmd>,<cmd>...`, `exec:full`, `pty:on`.+136
;;; Raises on a malformed spec, and on an fs path that does not+137
;;; exist (grants are anchored to real, canonical directories).+138
(define (grant-add! g spec)+139
(: any? string? -> void?)+140
(let ((parts (string-split spec ":")))+141
(cond+142
;; fs:ro:<path> / fs:rw:<path> — path may itself contain ':'+143
((and (>= (length parts) 3)+144
(string=? (car parts) "fs"))+145
(let ((mode (cadr parts))+146
(path (string-join (cddr parts) ":")))+147
(unless (or (string=? mode "ro") (string=? mode "rw"))+148
(error "grant-add!: fs mode must be ro or rw" spec))+149
(let ((root (realpath path)))+150
(unless root+151
(error "grant-add!: fs grant path does not exist" path))+152
(set-grants-fs-entries! g+153
(cons (cons (if (string=? mode "rw") 'rw 'ro) root)+154
(grants-fs-entries g))))))+155
+156
;; exec:full+157
((and (= (length parts) 2)+158
(string=? (car parts) "exec")+159
(string=? (cadr parts) "full"))+160
(set-grants-exec! g 'full))+161
+162
;; exec:allowlist:<cmd>,<cmd>+163
((and (= (length parts) 3)+164
(string=? (car parts) "exec")+165
(string=? (cadr parts) "allowlist"))+166
(let ((cmds (string-split (caddr parts) ","))+167
(existing (grants-exec g)))+168
;; 'full is strictly more permissive than any allowlist, so+169
;; adding an allowlist entry on top of full must NOT downgrade+170
;; the grant to that bounded list.+171
(unless (eq? existing 'full)+172
(set-grants-exec! g+173
(append cmds (if (pair? existing) existing '()))))))+174
+175
;; pty:on+176
((and (= (length parts) 2)+177
(string=? (car parts) "pty")+178
(string=? (cadr parts) "on"))+179
(set-grants-pty! g #t))+180
+181
(else+182
(error "grant-add!: malformed grant spec" spec)))))+183
+184
;; ============================================================+185
;; Checking+186
;; ============================================================+187
+188
;; Canonicalize a path for checking. Read targets must exist.+189
;; Write targets may be new files: canonicalize the parent+190
;; directory and re-attach the final component, so a symlinked+191
;; parent still cannot escape an allowed root.+192
(define (canonical-target path for-write?)+193
(or (realpath path)+194
(and for-write?+195
(let ((parent (realpath (path-dirname path))))+196
(and parent+197
(path-join parent (path-basename path)))))))+198
+199
;; Is p equal to root, or strictly under it? Component-safe:+200
;; "/a/bc" is NOT under "/a/b".+201
(define (path-under? root p)+202
(or (string=? p root)+203
(if (string=? root "/")+204
(string-starts-with? p "/")+205
(string-starts-with? p (string-append root "/")))))+206
+207
(define (fs-allowed? g path for-write?)+208
(let ((target (canonical-target path for-write?)))+209
(and target+210
(let loop ((entries (grants-fs-entries g)))+211
(cond+212
((null? entries) #f)+213
((and (path-under? (cdr (car entries)) target)+214
(or (not for-write?)+215
(eq? (car (car entries)) 'rw)))+216
#t)+217
(else (loop (cdr entries))))))))+218
+219
(define (exec-allowed? g command)+220
(let ((exec (grants-exec g)))+221
(cond+222
((eq? exec 'full) #t)+223
((pair? exec)+224
;; Match argv[0] EXACTLY against the allowlist. Matching on the+225
;; basename would be a hole: an allowlist entry "git" would then+226
;; also permit "/tmp/evil/git", i.e. any attacker-controlled+227
;; binary of the same name. So "git" allows only argv[0] = "git"+228
;; (resolved via PATH); to allow an absolute path, grant that+229
;; exact path.+230
(if (member command exec) #t #f))+231
(else #f))))+232
+233
;;; Check whether an operation is allowed. Records the decision in+234
;;; the audit log and returns a boolean.+235
;;;+236
;;; Operations: `'fs-read <path>`, `'fs-write <path>`,+237
;;; `'exec <command>`, `'pty <ignored>`.+238
(define (grant-check g op detail)+239
(: any? symbol? any? -> boolean?)+240
(record-decision! g op detail+241
(case op+242
((fs-read) (fs-allowed? g detail #f))+243
((fs-write) (fs-allowed? g detail #t))+244
((exec) (exec-allowed? g detail))+245
((pty) (grants-pty g))+246
(else #f))))+247
+248
;;; Like `grant-check`, but raises a `grant-denied` error when the+249
;;; operation is not allowed. Every capability entry point in+250
;;; (sigil system fs|process|session) calls this first.+251
(define (grant-assert! g op detail)+252
(: any? symbol? any? -> void?)+253
(unless (grant-check g op detail)+254
(error "grant-denied" (dict principal: (grants-principal g)+255
op: op+256
detail: detail))))))src/sigil/system/process.sgladded
@@ -0,0 +1,120 @@
+1
;;; (sigil system process) - Grant-Checked One-Shot Execution+2
;;;+3
;;; The Resource-plane exec surface: run a command to completion and+4
;;; capture its output. Commands are argv LISTS, never shell strings —+5
;;; anything that needs a shell goes through a PTY session running the+6
;;; user's shell (see `(sigil system session)`), where that choice is+7
;;; explicit.+8
;;;+9
;;; ```scheme+10
;;; (import (sigil system grant)+11
;;; (sigil system process))+12
;;;+13
;;; (define g (make-grants))+14
;;; (grant-add! g "exec:allowlist:ls,git")+15
;;;+16
;;; (define r (process-exec g '("ls" "-la" "/tmp")))+17
;;; (dict-ref r exit:) ; => 0+18
;;; (dict-ref r stdout:) ; => "total 42\n..."+19
;;; (dict-ref r stderr:) ; => ""+20
;;; ```+21
+22
(define-library (sigil system process)+23
(import (sigil process)+24
(sigil fs)+25
(sigil io)+26
(sigil async)+27
(sigil channels)+28
(sigil system grant))+29
+30
(export+31
process-exec)+32
+33
(begin+34
+35
;; Read everything from a port. Pipe ports are async-aware in+36
;; (sigil io): inside a scheduler, read-line yields to the fd+37
;; waiters instead of blocking the VM, so stdout and stderr readers+38
;; running as concurrent goroutines interleave and never deadlock on+39
;; a full pipe buffer.+40
(define (read-all port)+41
(if port+42
(let loop ((chunks '()))+43
(let ((line (read-line port)))+44
(if (eof-object? line)+45
(string-join (reverse chunks) "\n")+46
(loop (cons line chunks)))))+47
""))+48
+49
;;; Run a command to completion and capture the result.+50
;;;+51
;;; `argv` is a non-empty list: the command and its arguments.+52
;;; Returns `#{ exit: <integer> stdout: <string> stderr: <string> }`.+53
;;; Raises `grant-denied` unless the grants table allows executing+54
;;; the command.+55
;;;+56
;;; With `cwd:`, the child runs in that directory (which also needs+57
;;; a read grant).+58
;;;+59
;;; stdout and stderr are ALWAYS drained concurrently, so a+60
;;; stderr-heavy (or stdout-heavy) child can never deadlock on a full+61
;;; pipe buffer. When called outside an async context, an internal+62
;;; scheduler is spun up for the duration so the same concurrent+63
;;; drain applies.+64
(define (process-exec g argv (keys: (cwd #f)))+65
(: any? list? (cwd: any?) -> dict?)+66
(unless (and (pair? argv) (string? (car argv)))+67
(error "process-exec: argv must be a non-empty list of strings" argv))+68
(grant-assert! g 'exec (car argv))+69
(when cwd+70
(grant-assert! g 'fs-read cwd))+71
(let ((p (if cwd+72
;; (sigil process) has no native cwd support yet; the+73
;; working directory is process-global, so scope the+74
;; change tightly around the spawn (no yield point in+75
;; between).+76
(with-current-directory cwd+77
(apply process-spawn (car argv) (cdr argv)))+78
(apply process-spawn (car argv) (cdr argv)))))+79
(unless p+80
(error "process-exec: failed to spawn" argv))+81
(if (in-async-context?)+82
(drain-and-reap p)+83
;; Sync caller: run the concurrent drain under a private+84
;; scheduler. The result is captured in a box because+85
;; with-async returns the scheduler's status symbol, not the+86
;; body value.+87
(let ((box (vector #f)))+88
(with-async+89
(vector-set! box 0 (drain-and-reap p)))+90
(vector-ref box 0)))))+91
+92
;; Drain stdout+stderr concurrently, then reap. MUST run inside a+93
;; scheduler (the two readers are goroutines).+94
(define (drain-and-reap p)+95
(let ((out-ch (make-channel 1))+96
(err-ch (make-channel 1)))+97
;; Each reader always reports on its channel, even if read-all+98
;; raises — otherwise a mid-stream read error would leave the+99
;; join waiting forever.+100
(go (channel-send out-ch (guarded-read (process-stdout p))))+101
(go (channel-send err-ch (guarded-read (process-stderr p))))+102
(let ((out (channel-receive out-ch))+103
(err (channel-receive err-ch)))+104
(dict exit: (reap p) stdout: out stderr: err))))+105
+106
(define (guarded-read port)+107
(guard (e (#t ""))+108
(read-all port)))+109
+110
;; Reap without blocking the scheduler. Both pipes are at EOF here,+111
;; which usually means the child exited, but not always (it may have+112
;; closed stdout/stderr and lingered). Poll process-alive? (a+113
;; non-blocking waitpid(WNOHANG) that reaps and caches the status on+114
;; exit) so a lingering child never freezes the VM; process-wait then+115
;; returns the cached status.+116
(define (reap p)+117
(let loop ()+118
(if (process-alive? p)+119
(begin (sleep 0.005) (loop))+120
(process-wait p))))))src/sigil/system/proof.sgladded
@@ -0,0 +1,66 @@
+1
;;; Headless PTY proof — the S0 exit criterion.+2
;;;+3
;;; Using ONLY sigil-system (no Slate, no Lantern, no Enclave): open a+4
;;; PTY session, run a command, stream its output, resize the pty, and+5
;;; reap the child cleanly.+6
;;;+7
;;; Run with the DEV sigil built from the patched monorepo (package.sgl+8
;;; sets this module as the entry point):+9
;;; sigil run --redirects dev-redirects.sgl+10
;;;+11
;;; The same open/stream/resize/reap flow is also exercised, assertion+12
;;; by assertion, in test/test-system.sgl ("pty session" group).+13
+14
(define-library (sigil system proof)+15
(import (sigil async)+16
(sigil channels)+17
(sigil io)+18
(sigil string)+19
(sigil system grant)+20
(sigil system session))+21
+22
(export main)+23
+24
(begin+25
+26
(define (main)+27
;; Deny-by-default grants, then allow exactly what the proof needs.+28
(define g (make-grants principal: "proof"))+29
(grant-add! g "pty:on")+30
(grant-add! g "exec:allowlist:sh")+31
+32
(with-async+33
(let ((s (session-open+34
g+35
(dict kind: 'pty+36
argv: '("sh" "-c"+37
"ls / ; echo __READY__ ; sleep 0.2 ; stty size")+38
cols: 80 rows: 24))))+39
(println "session opened: id=~a kind=~a"+40
(session-id s) (session-kind s))+41
+42
;; Resize partway through: the script's `stty size` prints the+43
;; CURRENT window, which must reflect the resize below.+44
(session-resize s 132 50)+45
+46
(let ((acc '()))+47
(for-channel (ev (session-events s))+48
(case (dict-ref ev type:)+49
((data)+50
(let ((bytes (dict-ref ev bytes:)))+51
(set! acc (cons (utf8->string bytes) acc))+52
;; Replenish the flow-control window as we consume.+53
(session-credit s (bytevector-length bytes))))+54
((exit)+55
(let ((text (apply string-append (reverse acc))))+56
(println "----- child output -----")+57
(display text)+58
(newline)+59
(println "----- end output -----")+60
(println "saw READY marker: ~a"+61
(string-contains? text "__READY__"))+62
(println "saw resized size 50 132: ~a"+63
(string-contains? text "50 132"))+64
(println "exit code: ~a" (dict-ref ev code:))+65
(println "alive after exit: ~a"+66
(session-alive? s))))))))))))src/sigil/system/session.sgladded
@@ -0,0 +1,426 @@
+1
;;; (sigil system session) - Session-Plane Stream Sessions+2
;;;+3
;;; The Session plane: bidirectional, flow-controlled byte streams over+4
;;; long-lived children — PTY shells first. Where the Resource plane+5
;;; (`(sigil system fs)` / `(sigil system process)`) moves whole values+6
;;; at gesture rate, a session is a stateful stream: opened, written to+7
;;; at keystroke rate, read as chunked byte events, resized, signalled,+8
;;; and finally closed and reaped.+9
;;;+10
;;; Sessions REQUIRE an async context (`with-async`): opening a session+11
;;; spawns a reader pump and a writer drain as goroutines.+12
;;;+13
;;; ## Consuming+14
;;;+15
;;; `session-events` is a channel of event dicts, in order:+16
;;;+17
;;; - `#{ type: data session: <id> stream: out bytes: <bytevector> }`+18
;;; - `#{ type: exit session: <id> code: <n> }` (last event; the+19
;;; channel is closed after it)+20
;;;+21
;;; Chunk boundaries carry no meaning; consumers must parse+22
;;; incrementally.+23
;;;+24
;;; ## Flow control+25
;;;+26
;;; Credit-based windowing: a session starts with `credit:` bytes of+27
;;; window (default 256 KiB); every delivered data event consumes+28
;;; window; `session-credit` replenishes it as the consumer processes+29
;;; data. When the window is exhausted the pump stops READING the pty+30
;;; master, the kernel buffer fills, and the child blocks on write —+31
;;; backpressure reaches a flooding producer through the kernel's own+32
;;; mechanism with no buffering growth anywhere in between.+33
;;;+34
;;; ## Writing+35
;;;+36
;;; `session-write` enqueues and returns; a drain goroutine feeds the+37
;;; pty as it accepts bytes (handling partial writes and EAGAIN). No+38
;;; caller ever blocks per-keystroke. If the outbound queue fills+39
;;; (default 64 chunks), `session-write` blocks until the drain catches+40
;;; up — bounded memory, honest backpressure.+41
;;;+42
;;; ```scheme+43
;;; (import (sigil async) (sigil channels)+44
;;; (sigil system grant) (sigil system session))+45
;;;+46
;;; (define g (make-grants))+47
;;; (grant-add! g "exec:allowlist:sh")+48
;;; (grant-add! g "pty:on")+49
;;;+50
;;; (with-async+51
;;; (let ((s (session-open g (dict kind: 'pty argv: '("sh")+52
;;; cols: 120 rows: 40))))+53
;;; (session-write s "ls\n")+54
;;; (for-channel (ev (session-events s))+55
;;; (case (dict-ref ev type:)+56
;;; ((data) (consume (dict-ref ev bytes:))+57
;;; (session-credit s (bytevector-length (dict-ref ev bytes:))))+58
;;; ((exit) (println "exit: ~a" (dict-ref ev code:)))))))+59
;;; ```+60
+61
(define-library (sigil system session)+62
(import (sigil process)+63
(sigil math)+64
(sigil async)+65
(sigil channels)+66
(sigil system grant))+67
+68
(export+69
session-open+70
session?+71
session-id+72
session-kind+73
session-events+74
session-write+75
session-resize+76
session-signal+77
session-close+78
session-credit+79
session-alive?+80
session-exit-status+81
*default-credit-window*)+82
+83
(begin+84
+85
;;; Initial flow-control window in bytes.+86
(define *default-credit-window* (* 256 1024))+87
+88
;; Max bytes per read; also the biggest single data event.+89
(define *read-chunk-size* 65536)+90
+91
;; Outbound queue depth (chunks) before session-write blocks.+92
(define *write-queue-depth* 64)+93
+94
(define *next-session-id* 0)+95
+96
;; Session record:+97
;; (vector 'session id kind proc events out-queue window credit-wake+98
;; exit-status closing?)+99
;; events: channel of event dicts (reader pump -> consumer)+100
;; out-queue: channel of string|bytevector (caller -> writer drain)+101
;; window: remaining credit in bytes (box via vector slot)+102
;; credit-wake: unbuffered-ish channel the pump parks on at zero window+103
;; exit-status: #f until reaped+104
;; closing?: #t once session-close has run+105
+106
(define (session-vector id kind proc events out-queue window credit-wake)+107
(vector 'session id kind proc events out-queue window credit-wake #f #f))+108
+109
;;; Check if a value is a session.+110
(define (session? obj)+111
(: any? -> boolean?)+112
(and (vector? obj)+113
(> (vector-length obj) 0)+114
(eq? (vector-ref obj 0) 'session)))+115
+116
;;; The session's id (a monotonically increasing integer).+117
(define (session-id s) (: any? -> integer?) (vector-ref s 1))+118
+119
;;; The session's kind (currently always `pty`).+120
(define (session-kind s) (: any? -> symbol?) (vector-ref s 2))+121
+122
(define (session-proc s) (vector-ref s 3))+123
+124
;;; The session's event channel: `data` events then one `exit`+125
;;; event, after which the channel is closed.+126
(define (session-events s) (: any? -> any?) (vector-ref s 4))+127
+128
(define (session-out-queue s) (vector-ref s 5))+129
(define (session-window s) (vector-ref s 6))+130
(define (set-session-window! s n) (vector-set! s 6 n))+131
(define (session-credit-wake s) (vector-ref s 7))+132
+133
;;; The child's exit status, or #f while it is still running.+134
(define (session-exit-status s) (: any? -> any?) (vector-ref s 8))+135
(define (set-session-exit-status! s v) (vector-set! s 8 v))+136
+137
(define (session-closing? s) (vector-ref s 9))+138
(define (set-session-closing! s) (vector-set! s 9 #t))+139
+140
;;; Is the session's child still running?+141
(define (session-alive? s)+142
(: any? -> boolean?)+143
(and (not (session-exit-status s))+144
(process-alive? (session-proc s))))+145
+146
;; ============================================================+147
;; Opening+148
;; ============================================================+149
+150
;;; Open a stream session.+151
;;;+152
;;; `spec` is a dict:+153
;;;+154
;;; - `kind:` — `'pty` (a pseudo-terminal session; the only kind in+155
;;; this release. A pipe-based `'process` kind follows.)+156
;;; - `argv:` — non-empty command list, e.g. `'("bash" "-l")`+157
;;; - `cwd:` — child working directory (optional)+158
;;; - `cols:` / `rows:` — initial terminal size (default 80x24)+159
;;; - `term:` — TERM value (default "xterm-256color")+160
;;; - `credit:` — initial flow-control window in bytes+161
;;;+162
;;; Grant checks: `pty` must be granted, and `exec` must allow+163
;;; `(car argv)`. Must be called inside `with-async`.+164
(define (session-open g spec)+165
(: any? dict? -> any?)+166
(unless (in-async-context?)+167
(error "session-open: requires an async context (with-async)"))+168
(let ((kind (dict-ref spec kind:))+169
(argv (dict-ref spec argv:)))+170
(unless (eq? kind 'pty)+171
(error "session-open: unsupported session kind" kind))+172
(unless (and (pair? argv) (string? (car argv)))+173
(error "session-open: argv must be a non-empty list of strings" argv))+174
(grant-assert! g 'pty #t)+175
(grant-assert! g 'exec (car argv))+176
(when (dict-contains? spec cwd:)+177
(grant-assert! g 'fs-read (dict-ref spec cwd:)))+178
(let* ((cols (if (dict-contains? spec cols:) (dict-ref spec cols:) 80))+179
(rows (if (dict-contains? spec rows:) (dict-ref spec rows:) 24))+180
(cwd (if (dict-contains? spec cwd:) (dict-ref spec cwd:) #f))+181
(term (if (dict-contains? spec term:)+182
(dict-ref spec term:)+183
"xterm-256color"))+184
(credit (if (dict-contains? spec credit:)+185
(dict-ref spec credit:)+186
*default-credit-window*))+187
(proc (apply process-spawn-pty+188
(car argv)+189
cols: cols rows: rows cwd: cwd term: term+190
die-with-parent: #t+191
(cdr argv))))+192
(unless (process? proc)+193
(error "session-open: failed to spawn" argv))+194
(set! *next-session-id* (+ *next-session-id* 1))+195
(let ((s (session-vector *next-session-id* kind proc+196
(make-channel *write-queue-depth*)+197
(make-channel *write-queue-depth*)+198
credit+199
(make-channel 1))))+200
(go (reader-pump s))+201
(go (writer-drain s))+202
s))))+203
+204
;; ============================================================+205
;; The reader pump+206
;; ============================================================+207
+208
;; Read child output from the pty master and deliver data events,+209
;; respecting the credit window; on EOF, reap and deliver exit.+210
(define (reader-pump s)+211
(let ((proc (session-proc s))+212
(events (session-events s)))+213
(let ((fd (process-pty-fd proc)))+214
(let loop ()+215
(cond+216
;; Window exhausted: park until session-credit wakes us.+217
;; (Or until close: session-close also pokes the wake+218
;; channel so a zero-window session can still shut down.)+219
((<= (session-window s) 0)+220
(channel-receive (session-credit-wake s))+221
(loop))+222
(else+223
(await-readable-fd fd)+224
(let ((chunk (process-pty-read+225
proc+226
(min *read-chunk-size* (session-window s)))))+227
(cond+228
((eof-object? chunk)+229
(reap-session s))+230
((= (bytevector-length chunk) 0)+231
;; Spurious wakeup (EAGAIN); await again.+232
(loop))+233
(else+234
(set-session-window! s (- (session-window s)+235
(bytevector-length chunk)))+236
;; Bounded delivery: blocks when the consumer lags+237
;; a full buffer behind, which is exactly the+238
;; in-process meaning of the window.+239
(channel-send events+240
(dict type: 'data+241
session: (session-id s)+242
stream: 'out+243
bytes: chunk))+244
(loop))))))))))+245
+246
;; EOF on the master: reap the child, deliver the exit event, close+247
;; the channels. Ordering is load-bearing for teardown safety:+248
;; reap-child! sets exit-status (and only returns once the child is+249
;; dead, so the master is writable) BEFORE we close the out-queue and+250
;; the master. That guarantees we never close the pty master out from+251
;; under a writer-drain that is still about to await it (a select on a+252
;; just-closed fd never reports ready and would wedge the goroutine).+253
(define (reap-session s)+254
(let ((proc (session-proc s)))+255
(reap-child! s proc)+256
;; Release the writer: closing the out-queue wakes a writer parked+257
;; on the queue receive; exit-status (already set) stops one+258
;; parked mid-write. Only then close the master.+259
(channel-close! (session-out-queue s))+260
(process-pty-close! proc)+261
(channel-send (session-events s)+262
(dict type: 'exit+263
session: (session-id s)+264
code: (session-exit-status s)))+265
(channel-close! (session-events s))))+266
+267
;; Reap the child cooperatively and set exit-status. process-alive? is+268
;; a non-blocking waitpid(WNOHANG) that reaps and caches the status on+269
;; exit, so the following process-wait returns the cached status+270
;; without blocking the VM. The poll is BOUNDED so a wedged grandchild+271
;; that keeps the slave open cannot spin the reap forever; if the+272
;; child outlives the grace window it is force-killed, and if even+273
;; that fails the session still tears down with an unknown status+274
;; rather than hanging. Shared by the EOF path and session-close.+275
(define (reap-child! s proc)+276
(unless (session-exit-status s)+277
(let poll ((tries 400)) ; ~4s at 10ms+278
(cond+279
((not (process-alive? proc))+280
(set-session-exit-status! s (process-wait proc)))+281
((> tries 0)+282
(sleep 0.01)+283
(poll (- tries 1)))+284
(else+285
(process-signal! proc 'kill)+286
(let kpoll ((ktries 200)) ; ~2s more+287
(cond+288
((not (process-alive? proc))+289
(set-session-exit-status! s (process-wait proc)))+290
((> ktries 0) (sleep 0.01) (kpoll (- ktries 1)))+291
(else (set-session-exit-status! s -1)))))))))+292
+293
;; ============================================================+294
;; The writer drain+295
;; ============================================================+296
+297
;; Feed queued input to the pty master, handling partial writes and+298
;; EAGAIN via the fd waiters. Chunks are strings or bytevectors; a+299
;; partial write re-slices the remainder (copying at most once). The+300
;; write is guarded: once the child has exited, a write to the master+301
;; fails (EIO, or the fd is closed) — that surfaces as an error which+302
;; we swallow and stop, dropping the remaining input rather than+303
;; letting the goroutine die with an unhandled error. The await is+304
;; only reached when the session has NOT exited (checked with no yield+305
;; point in between), so we never park on a closed fd.+306
(define (writer-drain s)+307
(let ((fd (process-pty-fd (session-proc s))))+308
(for-channel (data (session-out-queue s))+309
(let wloop ((data data))+310
(unless (session-exit-status s)+311
(let* ((len (if (bytevector? data)+312
(bytevector-length data)+313
(string-length data)))+314
(n (guarded-pty-write s data)))+315
(cond+316
((eq? n 'failed) #t) ; child gone: drop the remainder+317
((< n len)+318
(unless (session-exit-status s)+319
(await-writable-fd fd)+320
(wloop+321
;; Strings are written as UTF-8; a partial write+322
;; may split a multi-byte character, so requeue the+323
;; remainder as raw bytes.+324
(if (bytevector? data)+325
(bytevector-copy data n)+326
(bytevector-copy (string->utf8 data) n))))))))))))+327
+328
(define (guarded-pty-write s data)+329
(guard (e (#t 'failed))+330
(process-pty-write (session-proc s) data)))+331
+332
;; ============================================================+333
;; Driving+334
;; ============================================================+335
+336
;;; Queue bytes (a string or bytevector) for the child's stdin.+337
;;; Enqueue-and-drain: returns as soon as the chunk is queued;+338
;;; blocks only if the outbound queue is full.+339
;;;+340
;;; Raises `session-write: session has exited` if the session is+341
;;; already gone. If the child exits WHILE this call is blocked on a+342
;;; full queue (reap closes the out-queue), the enqueue is dropped+343
;;; rather than surfacing the raw closed-channel error.+344
(define (session-write s data)+345
(: any? any? -> void?)+346
(when (session-exit-status s)+347
(error "session-write: session has exited" (session-id s)))+348
(guard (e ((session-exit-status s) #f) ; queue closed by reap: drop+349
(else (raise e)))+350
(channel-send (session-out-queue s) data)))+351
+352
;;; Resize the session's terminal. The kernel delivers SIGWINCH to+353
;;; the child's foreground process group.+354
(define (session-resize s cols rows)+355
(: any? integer? integer? -> void?)+356
(unless (session-exit-status s)+357
(process-pty-resize! (session-proc s) cols rows)))+358
+359
;;; Send a signal to the session's process group. Accepts the+360
;;; symbols `(sigil process)`'s process-signal! accepts+361
;;; (`'int` `'term` `'hup` `'kill` ...) or a signal number.+362
(define (session-signal s sig)+363
(: any? any? -> boolean?)+364
(if (session-exit-status s)+365
#f+366
(process-signal! (session-proc s) sig)))+367
+368
;;; Grant the producer more flow-control window (bytes). Call as+369
;;; data events are consumed.+370
;;;+371
;;; Contract: a consumer must keep crediting until it observes the+372
;;; `exit` event, OR call `session-close`. A pump parked at a zero+373
;;; window is not watching the pty fd, so it cannot observe the child+374
;;; exiting on its own; a consumer that stops crediting a live-but-+375
;;; then-exiting session without closing it would leave the session+376
;;; un-reaped. Crediting normally (or closing) avoids this.+377
(define (session-credit s n)+378
(: any? integer? -> void?)+379
(set-session-window! s (+ (session-window s) n))+380
;; Wake a parked pump; try-send so repeated credits don't block.+381
(channel-try-send (session-credit-wake s) #t))+382
+383
;;; Close the session: signal the child to exit (SIGHUP, then+384
;;; SIGKILL if it lingers) and let the reader pump observe EOF and+385
;;; reap. Blocks (cooperatively) until the exit event is delivered.+386
;;; Idempotent.+387
;;;+388
;;; Note we do NOT close the pty master here: the reader pump is the+389
;;; sole owner of that fd and closes it in `reap-session`. Closing it+390
;;; out from under a pump parked in `await-readable-fd` would wedge+391
;;; the pump (a select on a closed fd never reports readable). Killing+392
;;; the child instead closes the slave, which makes the master read+393
;;; EOF and drives the normal reap path. Callers must still be+394
;;; draining `session-events` (directly or via a goroutine) so the+395
;;; pump's final data/exit sends do not block.+396
(define (session-close s)+397
(: any? -> any?)+398
(unless (or (session-closing? s) (session-exit-status s))+399
(set-session-closing! s)+400
;; Grant generous credit so a window-throttled pump can drain to+401
;; EOF, and wake a pump parked at zero window.+402
(session-credit s (* 4 *read-chunk-size*))+403
(let ((proc (session-proc s)))+404
(when (process-alive? proc)+405
(process-signal! proc 'hup))+406
;; Grace period: most children exit on hangup. The pump sees+407
;; the resulting EOF and reaps, setting exit-status.+408
(let grace ((tries 50))+409
(when (and (> tries 0) (not (session-exit-status s)))+410
(sleep 0.02)+411
(grace (- tries 1))))+412
;; Escalate for children that ignore SIGHUP.+413
(when (and (not (session-exit-status s))+414
(process-alive? proc))+415
(process-signal! proc 'kill)+416
(let wait-exit ((tries 150))+417
(when (and (> tries 0) (not (session-exit-status s)))+418
(sleep 0.02)+419
(wait-exit (- tries 1)))))+420
;; If the pump never reaped (e.g. it is blocked delivering+421
;; events to a consumer that stopped draining session-events),+422
;; reap here so session-close is authoritative: it must not+423
;; return #f — "still alive" — for a child it has already+424
;; killed. reap-child! is bounded and idempotent with the pump.+425
(reap-child! s proc)))+426
(session-exit-status s))))test/test-system.sgladded
@@ -0,0 +1,261 @@
+1
;;; Tests for sigil-system: grant engine, fs capability, one-shot exec,+2
;;; and the PTY session plane. The session tests ARE the S0 exit+3
;;; criterion exercised end to end (open a pty, run a command, stream+4
;;; output, resize, reap).+5
+6
(import (sigil test)+7
(sigil core)+8
(sigil io)+9
(sigil fs)+10
(sigil string)+11
(sigil async)+12
(sigil channels)+13
(sigil system grant)+14
(sigil system fs)+15
(sigil system process)+16
(sigil system session))+17
+18
;; ============================================================+19
;; Grant engine+20
;; ============================================================+21
+22
(test-group "grant engine"+23
+24
(test "deny by default"+25
(let ((g (make-grants)))+26
(assert-false (grant-check g 'pty #t))+27
(assert-false (grant-check g 'exec "ls"))+28
(assert-false (grant-check g 'fs-read "/etc/hosts"))))+29
+30
(test "pty grant"+31
(let ((g (make-grants)))+32
(grant-add! g "pty:on")+33
(assert-true (grant-check g 'pty #t))))+34
+35
(test "exec allowlist matches argv[0] exactly"+36
(let ((g (make-grants)))+37
(grant-add! g "exec:allowlist:ls,git")+38
(assert-true (grant-check g 'exec "ls"))+39
;; Exact match only: a same-named binary at another path is NOT+40
;; allowed (prevents an attacker-controlled /tmp/evil/ls bypass).+41
(assert-false (grant-check g 'exec "/tmp/evil/ls"))+42
(assert-false (grant-check g 'exec "rm"))))+43
+44
(test "exec:full is not downgraded by a later allowlist"+45
(let ((g (make-grants)))+46
(grant-add! g "exec:full")+47
(grant-add! g "exec:allowlist:ls")+48
(assert-true (grant-check g 'exec "anything-still"))))+49
+50
(test "exec full allows anything"+51
(let ((g (make-grants)))+52
(grant-add! g "exec:full")+53
(assert-true (grant-check g 'exec "anything"))))+54
+55
(test "fs ro allows read not write"+56
(let ((g (make-grants)))+57
(grant-add! g "fs:ro:/tmp")+58
(assert-true (grant-check g 'fs-read "/tmp"))+59
(assert-false (grant-check g 'fs-write "/tmp/x"))))+60
+61
(test "fs rw allows read and write under root"+62
(let ((g (make-grants)))+63
(grant-add! g "fs:rw:/tmp")+64
(assert-true (grant-check g 'fs-read "/tmp"))+65
(assert-true (grant-check g 'fs-write "/tmp/new-file"))))+66
+67
(test "fs grant does not leak to sibling prefix"+68
(let ((g (make-grants))+69
(base (make-temp-directory)))+70
;; /base/allow granted; /base/allowed must NOT be covered.+71
(make-directory (path-join base "allow"))+72
(make-directory (path-join base "allowed"))+73
(grant-add! g (string-append "fs:rw:" (path-join base "allow")))+74
(assert-true (grant-check g 'fs-write (path-join base "allow" "x")))+75
(assert-false (grant-check g 'fs-read (path-join base "allowed" "x")))))+76
+77
(test "malformed spec raises"+78
(let ((g (make-grants)))+79
(assert-error (grant-add! g "nonsense"))))+80
+81
(test "decisions are recorded"+82
(let ((g (make-grants)))+83
(grant-add! g "pty:on")+84
(grant-check g 'pty #t)+85
(grant-check g 'exec "ls")+86
(assert-equal (length (grant-decisions g)) 2)))+87
+88
(test "allow-all posture"+89
(let ((g (grant-allow-all)))+90
(assert-true (grant-check g 'pty #t))+91
(assert-true (grant-check g 'exec "anything"))+92
(assert-true (grant-check g 'fs-read "/etc/hosts")))))+93
+94
;; ============================================================+95
;; Filesystem capability+96
;; ============================================================+97
+98
(test-group "fs capability"+99
+100
(test "write then read a file"+101
(let ((g (make-grants))+102
(dir (make-temp-directory)))+103
(grant-add! g (string-append "fs:rw:" dir))+104
(let ((path (path-join dir "hello.txt")))+105
(fs-write-file g path "hi there\n")+106
(assert-equal (fs-read-file g path) "hi there\n"))))+107
+108
(test "read-dir returns stat dicts"+109
(let ((g (make-grants))+110
(dir (make-temp-directory)))+111
(grant-add! g (string-append "fs:rw:" dir))+112
(fs-write-file g (path-join dir "a.txt") "a")+113
(fs-write-file g (path-join dir "b.txt") "bb")+114
(let ((entries (fs-read-dir g dir)))+115
(assert-equal (length entries) 2)+116
(assert-true (dict-contains? (car entries) name:))+117
(assert-true (dict-contains? (car entries) size:)))))+118
+119
(test "stat reports type and size"+120
(let ((g (make-grants))+121
(dir (make-temp-directory)))+122
(grant-add! g (string-append "fs:rw:" dir))+123
(let ((path (path-join dir "sized.txt")))+124
(fs-write-file g path "12345")+125
(let ((st (fs-stat g path)))+126
(assert-equal (dict-ref st size:) 5)+127
(assert-equal (dict-ref st type:) 'regular)))))+128
+129
(test "read denied without grant"+130
(let ((g (make-grants))+131
(dir (make-temp-directory)))+132
;; No grant added.+133
(assert-error (fs-read-dir g dir))))+134
+135
(test "write denied under ro grant"+136
(let ((g (make-grants))+137
(dir (make-temp-directory)))+138
(grant-add! g (string-append "fs:ro:" dir))+139
(assert-error (fs-write-file g (path-join dir "x") "nope")))))+140
+141
;; ============================================================+142
;; One-shot exec+143
;; ============================================================+144
+145
(test-group "process-exec"+146
+147
(test "captures stdout and exit code"+148
(let ((g (make-grants)))+149
(grant-add! g "exec:allowlist:echo")+150
(let ((r (process-exec g '("echo" "hello world"))))+151
(assert-equal (dict-ref r exit:) 0)+152
(assert-true (string-contains? (dict-ref r stdout:) "hello world")))))+153
+154
(test "denied without grant"+155
(let ((g (make-grants)))+156
(assert-error (process-exec g '("echo" "no")))))+157
+158
(test "non-zero exit surfaces"+159
(let ((g (make-grants)))+160
(grant-add! g "exec:allowlist:false")+161
(let ((r (process-exec g '("false"))))+162
(assert-true (> (dict-ref r exit:) 0)))))+163
+164
(test "stderr-heavy command does not deadlock (concurrent drain)"+165
;; ~256 KiB to stderr while also writing stdout: with a sequential+166
;; drain-stdout-then-stderr this deadlocks on the stderr pipe buffer.+167
;; The concurrent drain must complete. Runs outside with-async, so it+168
;; exercises the internal-scheduler path.+169
(let ((g (make-grants)))+170
(grant-add! g "exec:allowlist:sh")+171
(let ((r (process-exec+172
g+173
'("sh" "-c"+174
"yes 0123456789 | head -n 20000 1>&2; echo done"))))+175
(assert-equal (dict-ref r exit:) 0)+176
(assert-true (string-contains? (dict-ref r stdout:) "done"))+177
(assert-true (> (string-length (dict-ref r stderr:)) 100000))))))+178
+179
;; ============================================================+180
;; PTY session plane — the S0 exit criterion+181
;; ============================================================+182
+183
(test-group "pty session"+184
+185
(test "open, stream ls, reap"+186
(let ((g (make-grants)))+187
(grant-add! g "pty:on")+188
(grant-add! g "exec:allowlist:ls")+189
(with-async+190
(let ((s (session-open g (dict kind: 'pty+191
argv: '("ls" "/")+192
cols: 80 rows: 24)))+193
(acc '())+194
(exit-code #f))+195
(assert-true (session? s))+196
(assert-equal (session-kind s) 'pty)+197
(for-channel (ev (session-events s))+198
(case (dict-ref ev type:)+199
((data)+200
(set! acc (cons (utf8->string (dict-ref ev bytes:)) acc))+201
(session-credit s (bytevector-length (dict-ref ev bytes:))))+202
((exit)+203
(set! exit-code (dict-ref ev code:)))))+204
(assert-equal exit-code 0)+205
;; `ls /` output should mention a well-known root entry.+206
(let ((text (apply string-append (reverse acc))))+207
(assert-true (string-contains? text "usr")))))))+208
+209
(test "resize is visible to the child"+210
(let ((g (make-grants)))+211
(grant-add! g "pty:on")+212
(grant-add! g "exec:allowlist:sh")+213
(with-async+214
(let ((s (session-open g (dict kind: 'pty+215
argv: '("sh" "-c" "sleep 0.2; stty size")+216
cols: 80 rows: 24)))+217
(acc '()))+218
(session-resize s 132 50)+219
(for-channel (ev (session-events s))+220
(when (eq? (dict-ref ev type:) 'data)+221
(set! acc (cons (utf8->string (dict-ref ev bytes:)) acc))+222
(session-credit s (bytevector-length (dict-ref ev bytes:)))))+223
;; stty prints "rows cols".+224
(let ((text (apply string-append (reverse acc))))+225
(assert-true (string-contains? text "50 132")))))))+226
+227
(test "write to stdin round-trips through the shell"+228
(let ((g (make-grants)))+229
(grant-add! g "pty:on")+230
(grant-add! g "exec:allowlist:sh")+231
(with-async+232
(let ((s (session-open g (dict kind: 'pty+233
argv: '("sh")+234
cols: 80 rows: 24)))+235
(acc '()))+236
(go (begin+237
(sleep 0.2)+238
(session-write s "echo round-trip-ok\n")+239
(sleep 0.3)+240
(session-write s "exit\n")))+241
(for-channel (ev (session-events s))+242
(when (eq? (dict-ref ev type:) 'data)+243
(set! acc (cons (utf8->string (dict-ref ev bytes:)) acc))+244
(session-credit s (bytevector-length (dict-ref ev bytes:)))))+245
(let ((text (apply string-append (reverse acc))))+246
(assert-true (string-contains? text "round-trip-ok")))))))+247
+248
(test "session-close terminates a long-running child"+249
(let ((g (make-grants)))+250
(grant-add! g "pty:on")+251
(grant-add! g "exec:allowlist:sh")+252
(with-async+253
(let ((s (session-open g (dict kind: 'pty+254
argv: '("sh" "-c" "sleep 30")+255
cols: 80 rows: 24))))+256
;; Drain events in the background so the pump can reach EOF.+257
(go (for-channel (ev (session-events s)) #t))+258
(sleep 0.2)+259
(let ((status (session-close s)))+260
(assert-true (not (eq? status #f)))+261
(assert-false (session-alive? s))))))))