Commit944b328dRecorded1 Aug 2026Repositorysigil-system

Merge feat/process-session-env: captured session cwd env and stderr

Changed
 src/sigil/system/session.sgl | 59 ++++++++++++++++++++++++++++++++++++++++++++++++-----------
 test/test-system.sgl         | 42 ++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 90 insertions(+), 11 deletions(-)
Diff

A merge. Shown against its first parent, so this is the effect of merging rather than the work of the branch.

src/sigil/system/session.sglmodified
@@ -60,6 +60,7 @@
60
61
(define-library (sigil system session)
62
(import (sigil process)
+63
(sigil dict)
64
(sigil math)
65
(sigil async)
66
(sigil channels)
@@ -93,6 +94,27 @@
94
95
(define *next-session-id* 0)
96
+97
;; Environment overrides are installed only for the synchronous span that
+98
;; forks the child. Sigil's VM is single-threaded and neither spawn
+99
;; primitive yields, so no other fiber can observe the temporary parent
+100
;; environment. Restore it before session-open returns (or re-raises).
+101
(define (call-with-environment env thunk)
+102
(let ((saved
+103
(map (lambda (entry)
+104
(let ((name (car entry)) (value (cdr entry)))
+105
(unless (and (string? name) (string? value))
+106
(error "session-open: env must map strings to strings" env))
+107
(cons name (getenv name))))
+108
(dict->alist env))))
+109
(define (restore!)
+110
(for-each (lambda (entry) (setenv! (car entry) (cdr entry))) saved))
+111
(guard (e (#t (restore!) (raise e)))
+112
(for-each (lambda (entry) (setenv! (car entry) (cdr entry)))
+113
(dict->alist env))
+114
(let ((result (thunk)))
+115
(restore!)
+116
result))))
+117
118
;; Session record:
119
;; (vector 'session id kind proc events out-queue window credit-wake
120
;; exit-status closing?)
@@ -158,6 +180,8 @@
180
;;; and hard-fails on a pty, e.g. `tmux -C`.
181
;;; - `argv:` — non-empty command list, e.g. `'("bash" "-l")`
182
;;; - `cwd:` — child working directory (optional)
+183
;;; - `env:` — string-to-string child environment overrides (optional)
+184
;;; - `stderr:` — `'merge` to merge stderr into captured process output
185
;;; - `cols:` / `rows:` — initial terminal size (default 80x24;
186
;;; ignored by the `'process` kind, which has no window)
187
;;; - `term:` — TERM value (default "xterm-256color"; `'pty` only)
@@ -185,23 +209,36 @@
209
(let* ((cols (if (dict-contains? spec cols:) (dict-ref spec cols:) 80))
210
(rows (if (dict-contains? spec rows:) (dict-ref spec rows:) 24))
211
(cwd (if (dict-contains? spec cwd:) (dict-ref spec cwd:) #f))
+212
(env (if (dict-contains? spec env:) (dict-ref spec env:) #{}))
+213
(stderr (if (dict-contains? spec stderr:)
+214
(dict-ref spec stderr:) #f))
215
(term (if (dict-contains? spec term:)
216
(dict-ref spec term:)
217
"xterm-256color"))
218
(credit (if (dict-contains? spec credit:)
219
(dict-ref spec credit:)
220
*default-credit-window*))
−194
(proc (if (eq? kind 'process)
−195
(apply process-spawn-pipe
−196
(car argv)
−197
cwd: cwd
−198
die-with-parent: #t
−199
(cdr argv))
−200
(apply process-spawn-pty
−201
(car argv)
−202
cols: cols rows: rows cwd: cwd term: term
−203
die-with-parent: #t
−204
(cdr argv)))))
+221
(_ (unless (dict? env)
+222
(error "session-open: env must be a dictionary" env)))
+223
(_ (unless (or (not stderr) (eq? stderr 'merge))
+224
(error "session-open: stderr must be merge when present" stderr)))
+225
(proc
+226
(call-with-environment
+227
env
+228
(lambda ()
+229
(if (eq? kind 'process)
+230
(apply (if (eq? stderr 'merge)
+231
process-spawn-pipe-merged
+232
process-spawn-pipe)
+233
(car argv)
+234
cwd: cwd
+235
die-with-parent: #t
+236
(cdr argv))
+237
(apply process-spawn-pty
+238
(car argv)
+239
cols: cols rows: rows cwd: cwd term: term
+240
die-with-parent: #t
+241
(cdr argv)))))))
242
(unless (process? proc)
243
(error "session-open: failed to spawn" argv))
244
(set! *next-session-id* (+ *next-session-id* 1))
test/test-system.sglmodified
@@ -362,6 +362,48 @@
362
(let ((text (apply string-append (reverse acc))))
363
(assert-true (string-contains? text "process-out")))))))
364
+365
(test "cwd and environment overrides reach the child and leave the parent unchanged"
+366
(let ((g (make-grants))
+367
(before (getenv "SIGIL_SESSION_ENV_TEST")))
+368
(grant-add! g "exec:allowlist:sh")
+369
(grant-add! g "fs:ro:/tmp")
+370
(with-async
+371
(let ((s (session-open
+372
g
+373
(dict kind: 'process
+374
argv: '("sh" "-c" "printf '%s|%s' \"$PWD\" \"$SIGIL_SESSION_ENV_TEST\"")
+375
cwd: "/tmp"
+376
env: #{ "SIGIL_SESSION_ENV_TEST" "task-value" })))
+377
(acc '()))
+378
(for-channel (ev (session-events s))
+379
(when (eq? (dict-ref ev type:) 'data)
+380
(set! acc (cons (utf8->string (dict-ref ev bytes:)) acc))
+381
(session-credit s (bytevector-length (dict-ref ev bytes:)))))
+382
(assert-equal (apply string-append (reverse acc)) "/tmp|task-value")
+383
(assert-equal (getenv "SIGIL_SESSION_ENV_TEST") before)))))
+384
+385
(test "environment overrides reject non-string values"
+386
(let ((g (make-grants)))
+387
(grant-add! g "exec:allowlist:true")
+388
(with-async
+389
(assert-error
+390
(session-open g (dict kind: 'process argv: '("true")
+391
env: #{ "COUNT" 3 }))))))
+392
+393
(test "process sessions optionally merge stderr into captured output"
+394
(let ((g (make-grants)))
+395
(grant-add! g "exec:allowlist:sh")
+396
(with-async
+397
(let ((s (session-open g (dict kind: 'process
+398
argv: '("sh" "-c" "printf ERR >&2")
+399
stderr: 'merge)))
+400
(acc '()))
+401
(for-channel (ev (session-events s))
+402
(when (eq? (dict-ref ev type:) 'data)
+403
(set! acc (cons (utf8->string (dict-ref ev bytes:)) acc))
+404
(session-credit s (bytevector-length (dict-ref ev bytes:)))))
+405
(assert-equal (apply string-append (reverse acc)) "ERR")))))
+406
407
(test "the process kind is denied without an exec grant"
408
(let ((g (make-grants)))
409
;; No exec grant at all: even with pty:on, exec gates the spawn.