sigil-system: add 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

src/sigil/system/session.sglmodified

@@ -60,6 +60,7 @@

(define-library (sigil system session)

(import (sigil process)

+63

(sigil dict)

(sigil math)

(sigil async)

(sigil channels)

@@ -93,6 +94,27 @@

(define *next-session-id* 0)

+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.